diff --git a/collects/racket/struct.rkt b/collects/racket/struct.rkt index f320467a46..1069aa54cc 100644 --- a/collects/racket/struct.rkt +++ b/collects/racket/struct.rkt @@ -26,8 +26,31 @@ (list (cons prop:equal+hash vector->list)))) (define-generics (equal+hash gen:equal+hash prop:gen:equal+hash equal+hash? - #:defined-table dummy + #:defined-table equal+hash-def-table #:prop-defined-already? gen:equal+hash-acc) (equal-proc equal+hash rhs equal?/recur) (hash-proc equal+hash equal-hash-code/recur) (hash2-proc equal+hash equal-secondary-hash-code/recur)) + + +(provide gen:custom-write) + +(define-values (prop:gen:custom-write gen:custom-write? gen:custom-write-acc) + (make-struct-type-property + 'prop:gen:custom-write + (lambda (v si) + (unless (and (vector? v) + (= 1 (vector-length v)) + (procedure? (vector-ref v 0)) + (procedure-arity-includes? (vector-ref v 0) 3)) + (raise-type-error 'guard-for-prop:gen:custom-write + "vector of one procedure (arity 3)" + v)) + v) + (list (cons prop:custom-write (lambda (v) (vector-ref v 0)))))) + +(define-generics (custom-write gen:custom-write prop:gen:custom-write + gen:custom-write? + #:defined-table custom-write-def-table + #:prop-defined-already? gen:custom-write-acc) + (write-proc custom-write port mode)) diff --git a/collects/tests/generics/custom-write.rkt b/collects/tests/generics/custom-write.rkt new file mode 100644 index 0000000000..97f82f5cd5 --- /dev/null +++ b/collects/tests/generics/custom-write.rkt @@ -0,0 +1,22 @@ +#lang racket + +(require racket/struct) + +(struct loud (v) + #:methods gen:custom-write + [(define (write-proc x port mode) + (displayln "writing!" port) + (case mode + [(#t) (write (loud-v x) port)] + [(#f) (display (loud-v x) port)] + [else (print (loud-v x) port mode)]))]) + +(module+ test + (require rackunit) + + (check-equal? (with-output-to-string (lambda () (write (loud 1)))) + "writing!\n1") + (check-equal? (with-output-to-string (lambda () (display (loud 1)))) + "writing!\n1") + (check-equal? (with-output-to-string (lambda () (print (loud 1)))) + "writing!\n1")) diff --git a/collects/tests/generics/tests.rkt b/collects/tests/generics/tests.rkt index 386e02ff7f..2dc252deea 100644 --- a/collects/tests/generics/tests.rkt +++ b/collects/tests/generics/tests.rkt @@ -7,4 +7,5 @@ (submod "iterator.rkt" test) (submod "struct-form.rkt" test) (submod "equal+hash.rkt" test) + (submod "custom-write.rkt" test) "from-unstable.rkt")