The following is in the right direction if you include the answer to invalid Symbol characters also.
opts = {"$divide$" :> "/", "$backslash$" :> "\\", "$period$" :> ".",
"$tilde$" :> "~", "$backtick$" :> "`", "$exclaim$" :> "!",
"$at$" :> "@", "$number$" :> "#", "$dollar$" :> "$",
"$percent$" :> "%", "$caret$" :> "^", "$amp$" :> "&",
"$multiply$" :> "*", "$parenleft$" :> "(", "$parenright$" :> ")",
"$underscore$" :> "_", "$dash$" :> "-", "$plus$" :> "+",
"$equal$" :> "=", "$barleft$" :> "[", "$barright$" :> "]",
"$bracketleft$" :> "{", "$bracketright$" :> "}", "$colon$" :> ":",
"$semicolon$" :> ";", "$singlequote$" :> "'",
"$doublequote$" :> "\"", "$lessthan$" :> "<", "$comma$" :> ",",
"$period$" :> ".", "$slash$" :> "/", "$question$" :> "?",
"$space$" :> " ", "$n$" :> "\n", "$r$" :> "\r"};
opts = Join[
Drop[Quiet[
Cases[Symbol[FromCharacterCode[#]] & /@ Range[0, 16^4 - 1],
Symbol[z__] -> (StringJoin@
Flatten@Join[{"$", IntegerString[ToCharacterCode[z], 16, 4],
"$"}] -> z)]], 1], opts];
Replace[a$multiply$[b$underscore$[c, d]],
head_[x___] :> $[StringReplace[ToString@head, opts]][x], {0,
Infinity}]
If you would like to display it in a pretty form you can do the following.
ReplaceRepeated[
ToBoxes[FullForm@Ti$at$mes[{a}, Rational[1, -2], "test"]][[1,
1]], {RowBox[{b_String, "[", x___String, "]"}] :>
StringJoin[{StringReplace[b, opts], "[", x, "]"}],
RowBox[{b___String}] :> StringJoin[{b}]}]