suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added prop:print-convert-constructor-name

Browse Source 
svn: r544
This commit is contained in:
Matthew Flatt 2005-08-04 03:49:35 +00:00
parent 98ed509542
commit e08138d97c
2 changed files with 36 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/mzlib/pconvert-prop.ss Normal file
View File

@ -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))))

17
collects/mzlib/pconvert.ss
View File

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