diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index 77d7889af3..ce0ba7f162 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/collects/racket/contract/private/misc.rkt @@ -827,6 +827,8 @@ (let* ([ctc (coerce-contract 'promise/c ctc-in)] [ctc-proc (contract-projection ctc)]) (define chap? (chaperone-contract? ctc)) + (define c/i-struct (if chap? chaperone-struct impersonate-struct)) + (define c/i-procedure (if chap? chaperone-procedure impersonate-procedure)) ((if chap? make-chaperone-contract make-contract) #:name (build-compound-type-name 'promise/c ctc) #:projection @@ -839,15 +841,13 @@ val '(expected "," given: "~e") val)) - (if chap? - (chaperone-struct - val - promise-forcer (λ (_ proc) - (chaperone-procedure - proc - (λ (promise) - (values p-app promise))))) - (delay (p-app (force val))))))) + (c/i-struct + val + promise-forcer (λ (_ proc) + (c/i-procedure + proc + (λ (promise) + (values p-app promise)))))))) #:first-order promise?)))) (define/subexpression-pos-prop (parameter/c x) diff --git a/collects/racket/private/promise.rkt b/collects/racket/private/promise.rkt index 19db951b2a..4ba6c01283 100644 --- a/collects/racket/private/promise.rkt +++ b/collects/racket/private/promise.rkt @@ -147,12 +147,7 @@ ;; property value for the right forcer to use (define-values [prop:force promise-forcer] (let-values ([(prop pred? get) ; no need for the predicate - (make-struct-type-property 'forcer - (lambda (v info) - (unless (and (procedure? v) - (procedure-arity-includes? v 1)) - (raise-argument-error 'prop:force "(any/c . -> . any)" v)) - v))]) + (make-struct-type-property 'forcer 'can-impersonate)]) (values prop get))) ;; A promise value can hold diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 1cf26f0bc5..a998f5f9fb 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -9255,6 +9255,16 @@ 'pos 'neg))) #t) + + (test/spec-passed/result + 'promise/c6 + '(let ([a (delay 7)]) + (equal? a + (contract (promise/c (new-∃/c 'α)) + a + 'pos + 'neg))) + #t) ;