diff --git a/collects/unstable/prop-contract.rkt b/collects/unstable/prop-contract.rkt new file mode 100644 index 0000000000..d7e5fbc851 --- /dev/null +++ b/collects/unstable/prop-contract.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require racket/contract/base) + +(define (get-stpc-proj stpc) + (let ([get-val-proj + (contract-projection + (struct-type-property/c-value-contract stpc))]) + (lambda (blame) + (let ([val-proj (get-val-proj (blame-swap blame))]) + (lambda (x) + (unless (struct-type-property? x) + (raise-blame-error blame x + "expected struct-type-property, given ~e" + x)) + (let-values ([(nprop _pred _acc) + (make-struct-type-property + (wrap-name x) + (lambda (val _info) + (val-proj val)) + (list (cons x values)))]) + nprop)))))) + +(define (wrap-name x) + (string->symbol (format "wrapped-~a" (object-name x)))) + +(struct struct-type-property/c (value-contract) + #:property prop:contract + (build-contract-property + #:name (lambda (c) + (build-compound-type-name + 'struct-type-property/c + (struct-type-property/c-value-contract c))) + #:first-order (lambda (c) struct-type-property?) + #:projection get-stpc-proj)) + +(define struct-type-property/c* + (let ([struct-type-property/c + (lambda (value-contract) + (struct-type-property/c + (coerce-contract 'struct-type-property/c value-contract)))]) + struct-type-property/c)) + +(provide (rename-out [struct-type-property/c* struct-type-property/c]))