added prop:print-convert-constructor-name

svn: r544

collects/mzlib/pconvert-prop.ss

@@ -0,0 +1,21 @@
+
+(module pconvert-prop mzscheme
+
+  (provide prop:print-convert-constructor-name
+	   print-convert-named-constructor?
+	   print-convert-constructor-name)
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; property recognized by print convert to set a value's constructor name:
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define-values (prop:print-convert-constructor-name
+		  print-convert-named-constructor?
+		  print-convert-constructor-name)
+    (make-struct-type-property 'print-convert-constructor-name
+			       (lambda (s info)
+				 (unless (symbol? s)
+				   (raise-type-error '|prop:print-convert-constructor-name guard|
+						     "symbol"
+						     s))
+				 s))))

collects/mzlib/pconvert.ss

@@ -2,7 +2,9 @@
 (module pconvert mzscheme
   
   (require (prefix s: "string.ss")
-           (prefix f: "list.ss"))
+           (prefix f: "list.ss")
+	   "etc.ss"
+	   "pconvert-prop.ss")
   (require "class.ss")
   (require "unit.ss")
   
@@ -413,13 +415,18 @@
                                
                                ;; this case must be next to last, so that all of the
                                ;; things with object-name's fall into the cases above first
-                               [(object-name expr)
+                               [(or (print-convert-named-constructor? expr)
-                                (let* ([name (object-name expr)]
+				    (object-name expr))
-                                       [str-name (if (string? name)
+                                (let ([constructor
-                                                     name
+				       (if (print-convert-named-constructor? expr)
-                                                     (symbol->string name))]
+					   (print-convert-constructor-name expr)
-                                       [uniq (box #f)])
+					   (let* ([name (object-name expr)]
-                                  `(,(string->symbol (string-append "make-" str-name))
+						  [str-name (if (string? name)
+								name
+								(symbol->string name))])
+					     (string->symbol (string-append "make-" str-name))))]
+				      [uniq (begin-lifted (box #f))])
+                                  `(,constructor
                                     ,@(map (lambda (x) 
                                              (if (eq? uniq x)
                                                  '...