Recently some functionality has been added, so updated code being posted.

To do: want to replace more of the ‘-1 … mul’ with ‘… neg’. Current code works in some situations, but fails with the likes of a-b^2. Suggestions welcomed.

    (* PostScriptForm[] *)
    (*
    	"http://mathematica.stackexchange.com/questions/101954/postscriptform-or-forthform"
    	"http://mathematica.stackexchange.com/questions/102894/multi-case-function-many-single-case-delayed-assignments-or-one-which"
    *)
    (*
    	Careful! The ‘ArcTan’ function in Mathematica returns things in radians; the ‘atan’ function in PostScript returns in degrees.
    	If doing angle-type calculations, this still works. If doing area-type calculations, it won’t unless atan multiplied by a factor of Pi÷180.
    *)
    Remove[PostScriptForm,PostScriptFormInner];
    PostScriptForm[thing_]:=StringTrim[StringReplace[StringJoin[" ",PostScriptFormInner[thing]],{
    	" -1 mul "->" neg ",
    	RegularExpression[" -1 ([A-Za-z][A-Za-z0-9]*) mul "]->" $1 neg ",
    	" 1 exch div mul "->" div ",
    	" div 1 atan "->" atan "
    }]];
    PostScriptFormInner[thing_Rational]:=If[Abs[Denominator[thing]/(2^IntegerExponent[Denominator[thing],2])/(5^IntegerExponent[Denominator[thing],5])]==1,ToString[N[thing,20],InputForm,NumberMarks->False],PostScriptFormInner[Numerator[thing]]<>" "<>PostScriptFormInner[Denominator[thing]]<>" div"];
    PostScriptFormInner[thing_?AtomQ]:=ToString[thing];
    PostScriptFormInner[thing_List]:=StringJoin@@Riffle[Map[PostScriptFormInner,thing],"\r\n"];
    PostScriptFormInner[MatrixForm[thing_]]:=PostScriptFormInner[thing];
    PostScriptFormInner[ArcTan[Times[Power[xThing_,n_],yThing_]]]:=StringJoin[PostScriptFormInner[yThing]," ",PostScriptFormInner[Power[xThing,-n]]," atan"]/;n<0;
    PostScriptFormInner[ArcTan[Times[yThing_,Power[xThing_,n_]]]]:=StringJoin[PostScriptFormInner[yThing]," ",PostScriptFormInner[Power[xThing,-n]]," atan"]/;n<0;
    PostScriptFormInner[ArcTan[Thing_]]:=StringJoin[PostScriptFormInner[Thing]," 1 atan "];
    PostScriptFormInner[ArcCsc[Times[h_,Power[x_,n_]]]]:=PostScriptFormInner[ArcTan[((x^(-n))//FullSimplify)/(Sqrt[h^2-x^(-2n)]//FullSimplify)]]/;n<0;
    PostScriptFormInner[ArcCsc[Times[Power[x_,n_],h_]]]:=PostScriptFormInner[ArcTan[((x^(-n))//FullSimplify)/(Sqrt[h^2-x^(-2n)]//FullSimplify)]]/;n<0;
    PostScriptFormInner[ArcCsc[Rational[h_,x_]]]:=PostScriptFormInner[ArcTan[(x//FullSimplify)/(Sqrt[h*h-x*x]//FullSimplify)]];
    
    PostScriptFormInner[thing_Power]:=(
    	psExponent:=Which[
    		#>5&&Divisible[#,3],psExponent[#/3]<>" dup dup mul mul",
    		#>=5&&OddQ[#],"dup "<>psExponent[(#-1)/2]<>" dup mul mul" ,
    		#>=4&&EvenQ[#],psExponent[#/2]<>" dup mul",
    		#==3,"dup dup mul mul",
    		#==2,"dup mul",
    		#==1/2,"sqrt",
    		#==3/2,"dup sqrt mul",
    		#<0,psExponent[-#]<> " 1 exch div",
    		(Rational===Head[#])&&(Log[2,#//Denominator]//IntegerQ),psExponent[Simplify[2#]]<>" sqrt",
    		Not[IntegerQ[#]],PostScriptFormInner[#]<>" exp",
    		#==1,"",
    		True," !!!\[Bullet]\[Bullet]\[Bullet]Error with exponent = "<>ToString[#]<> "\[Bullet]\[Bullet]\[Bullet]!!! "
    	]&;
    	Which[
    		thing[[2]]>0||Not[IntegerQ[thing[[2]]]],PostScriptFormInner[thing[[1]]]<>" "<>psExponent[thing[[2]]],
    		thing[[2]]==-1,"1 "<>PostScriptFormInner[thing[[1]]]<>" div",
    		thing[[2]]==0,"1",
    		True,"1 "<>PostScriptFormInner[thing[[1]]]<>" "<>psExponent[-thing[[2]]]<>" div"
    	]);
    
    PostScriptFormInner[thing_Times]:=StringJoin[PostScriptFormInner[-thing]," neg"]/;MemberQ[thing,-1];
    PostScriptFormInner[thing_Times]:=StringJoin@Riffle[Reap[If[MatchQ[thing[[1]],Power[_,n_Integer/;n<0]],(Sow["1 "<>PostScriptFormInner[thing[[1,1]]]<>" div"];),(Sow[PostScriptFormInner[thing[[1]]]];)];Map[(If[MatchQ[#,Power[_,n_Integer/;n<0]],(Sow[PostScriptFormInner[#[[1]]^(-#[[2]])]<>" div"];),(Sow[PostScriptFormInner[#]<>" mul"]; )])&,Drop[List@@thing,1]]][[2,1]]," "];
    
    PostScriptFormInner[thing_Plus]:=
    StringJoin@@If[FreeQ[thing,_^n_],
    	(* Simple expression, no powers, to be summed one item at a time *)
    	Module[{i},
    		i=Position[thing,Except[Times[-1,_]|(_?Negative)],1,Heads->False];
    		If[Length[i]>0,i=i[[1,1]],(i=Position[thing,Not[MatchQ[#,Times[-1,_]]]&,1,Heads->False];i=If[Length[i]>0,i[[1,1]],1])];	Prepend[Map[(" "<>Replace[#,{(n_Integer/;n<0:>ToString[-n]<>" sub"),(Times[-1,_]:>PostScriptFormInner[Times@@Drop[#,1]]<>" sub"),(Times[n_/;n<0,_]:>PostScriptFormInner[Times@@Drop[#,1]]<>" "<>ToString[-#[[1]]]<>" mul sub"),(Times[n_/;n>0,_]:>PostScriptFormInner[Times@@Drop[#,1]]<>" "<>ToString[#[[1]]]<>" mul add"),(_:>PostScriptFormInner[#]<>" add")}])&,Drop[List@@thing,{i}]],Replace[thing[[i]],{Times[-1,_]:>PostScriptFormInner[-thing[[i]]]<>" neg",_:>PostScriptFormInner[thing[[i]]]}]]  ],
    	(* Polynomial *)
    	Module[{vars,exps,v,rcl,i,firstMul},
    		vars=Variables[thing];
    		exps=Exponent[thing,vars];
    		v=Select[Transpose[{vars,exps}],(#[[2]]==Max@@exps)&][[1,1]];
    		rcl=Reverse[Map[Factor,CoefficientList[thing,v]]];
    		Reap[
    			i=1;firstMul=True;If[rcl[[1]]=!=1,Sow[PostScriptFormInner[rcl[[1]]]]];
    Map[If[#===0,i++,(Sow[If[firstMul&&rcl[[1]]===1,PostScriptFormInner[v^i]<>" "," "<>PostScriptFormInner[v^i]<>" mul "]<>If[MatchQ[#,(Times[_?Negative,_]|(_?Negative))],PostScriptFormInner[-#]<>" sub",PostScriptFormInner[#]<>" add"]];i=1;firstMul=False)]&,Drop[rcl,1]];
    			If[i>1,Sow[" "<>PostScriptFormInner[v^(i-1)]<>" mul "]];
    		][[2,1]]
    ]];