diff --git a/pkgs/racket-test/tests/racket/contract/equivalent.rkt b/pkgs/racket-test/tests/racket/contract/equivalent.rkt
index 20ff1c0c55..00917d9f91 100644
--- a/pkgs/racket-test/tests/racket/contract/equivalent.rkt
+++ b/pkgs/racket-test/tests/racket/contract/equivalent.rkt
@@ -224,6 +224,9 @@
(ctest #f contract-equivalent?
(parameter/c (between/c 1 4) (between/c 0 5))
(parameter/c (between/c 0 5) (between/c 1 4)))
+ (ctest #f contract-equivalent?
+ (parameter/c (between/c 0 5))
+ (parameter/c (between/c 0 5) (between/c 1 6)))
(ctest #f contract-equivalent? (symbols 'x 'y) (symbols 'x 'y 'z))
(ctest #f contract-equivalent? (symbols 'x 'y 'z) (symbols 'x 'y))
diff --git a/pkgs/racket-test/tests/racket/contract/parameter.rkt b/pkgs/racket-test/tests/racket/contract/parameter.rkt
index 3a2d616d41..b70b0f15cf 100644
--- a/pkgs/racket-test/tests/racket/contract/parameter.rkt
+++ b/pkgs/racket-test/tests/racket/contract/parameter.rkt
@@ -2,7 +2,7 @@
(require "test-util.rkt")
(parameterize ([current-contract-namespace
- (make-basic-contract-namespace)])
+ (make-basic-contract-namespace 'racket/contract/parametric)])
(test/neg-blame
'parameter/c1
@@ -47,4 +47,71 @@
'parameter/c7
'((contract (parameter/c integer? string?)
(make-parameter 5 values)
- 'pos 'neg))))
\ No newline at end of file
+ 'pos 'neg)))
+
+ (test/spec-passed/result
+ 'parameter/c8
+ '(let ([p (make-parameter 1)])
+ (parameter-procedure=?
+ (contract (parameter/c integer?)
+ p 'pos 'neg)
+ p))
+ #t)
+
+ (test/spec-passed/result
+ 'parameter/c9
+ '(let ([p (make-parameter 1)])
+ (chaperone-of?
+ (contract (parameter/c integer?)
+ p 'pos 'neg)
+ p))
+ #t)
+
+ (test/spec-passed/result
+ 'parameter/c10
+ '(let ([p (make-parameter 1)])
+ (parameter?
+ (contract (parameter/c integer?)
+ p 'pos 'neg)))
+ #t)
+
+
+ (test/spec-passed/result
+ 'parameter/c11
+ '(chaperone-contract?
+ (parameter/c integer?))
+ #t)
+
+ (test/spec-passed/result
+ 'parameter/c12
+ '(chaperone-contract?
+ (parameter/c (-> integer? integer?)))
+ #t)
+
+ (test/spec-passed/result
+ 'parameter/c13
+ '(chaperone-contract?
+ (parameter/c (new-∀/c 'α)))
+ #f)
+
+
+ (test/spec-passed/result
+ 'parameter/c14
+ '(chaperone-contract?
+ (parameter/c (new-∀/c 'α)
+ integer?))
+ #f)
+
+ (test/spec-passed/result
+ 'parameter/c15
+ '(chaperone-contract?
+ (parameter/c integer?
+ (new-∀/c 'α)))
+ #f)
+
+ (test/spec-passed/result
+ 'parameter/c16
+ '(chaperone-contract?
+ (parameter/c integer?
+ (-> integer? integer?)))
+ #t))
diff --git a/pkgs/racket-test/tests/racket/contract/stronger.rkt b/pkgs/racket-test/tests/racket/contract/stronger.rkt
index c6d3a5256c..1bdfecb79f 100644
--- a/pkgs/racket-test/tests/racket/contract/stronger.rkt
+++ b/pkgs/racket-test/tests/racket/contract/stronger.rkt
@@ -238,6 +238,7 @@
(parameter/c (between/c 1 4) (between/c 0 5)))
(ctest #f trust/not-stronger? (parameter/c (between/c 1 4) (between/c 0 5))
(parameter/c (between/c 0 5) (between/c 1 4)))
+ (ctest #f trust/not-stronger? (parameter/c (between/c 0 5)) (parameter/c (between/c 0 5) (between/c 1 6)))
(ctest #t trust/not-stronger? (symbols 'x 'y) (symbols 'x 'y 'z))
(ctest #f trust/not-stronger? (symbols 'x 'y 'z) (symbols 'x 'y))
diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt
index 066ffd6fae..eeb5fb0619 100644
--- a/racket/collects/racket/contract/private/misc.rkt
+++ b/racket/collects/racket/contract/private/misc.rkt
@@ -468,74 +468,120 @@
(case-lambda
[(in-ctc)
(define ctc (coerce-contract 'parameter/c in-ctc))
- (make-parameter/c ctc ctc #f)]
+ (cond
+ [(chaperone-contract? ctc)
+ (chaperone-parameter/c ctc #f)]
+ [else
+ (impersonator-parameter/c ctc #f)])]
[(in-ctc out-ctc)
- (make-parameter/c (coerce-contract 'parameter/c in-ctc)
- (coerce-contract 'parameter/c out-ctc)
- #t)]))
+ (define in (coerce-contract 'parameter/c in-ctc))
+ (define out (coerce-contract 'parameter/c out-ctc))
+ (cond
+ [(and (chaperone-contract? in) (chaperone-contract? out))
+ (chaperone-parameter/c in out)]
+ [else
+ (impersonator-parameter/c in out)])]))
+(define (parameter/c-lnp ctc)
+ (define in-proc (get/build-late-neg-projection (base-parameter/c-in ctc)))
+ (define out-proc (if (base-parameter/c-out/f ctc)
+ (get/build-late-neg-projection (base-parameter/c-out/f ctc))
+ in-proc))
+ (λ (blame)
+ (define blame/c (blame-add-context blame "the parameter of"))
+ (define in-proj (in-proc (blame-swap blame/c)))
+ (define out-proj (out-proc blame/c))
+ (λ (val neg-party)
+ (define blame+neg-party (cons blame/c neg-party))
+ (cond
+ [(parameter? val)
+ (chaperone-procedure
+ val
+ (case-lambda
+ [(x)
+ (with-contract-continuation-mark
+ blame+neg-party
+ (in-proj x neg-party))]
+ [() (λ (res)
+ (with-contract-continuation-mark
+ blame+neg-party
+ (out-proj res neg-party)))])
+ impersonator-prop:contracted ctc
+ impersonator-prop:blame blame+neg-party)]
+ [else
+ (raise-blame-error blame #:missing-party neg-party
+ val '(expected "a parameter"))]))))
+
+(define (parameter/c-name ctc)
+ (define out (base-parameter/c-out/f ctc))
+ (apply build-compound-type-name
+ `(parameter/c ,(base-parameter/c-in ctc)
+ ,@(if out
+ (list out)
+ (list)))))
+
+(define (parameter/c-first-order ctc)
+ (define tst (contract-first-order (base-parameter/c-out ctc)))
+ (λ (x)
+ (and (parameter? x)
+ (tst (x)))))
+
+(define (parameter/c-stronger this that)
+ (and (base-parameter/c? that)
+ (cond
+ [(or (base-parameter/c-out/f this)
+ (base-parameter/c-out/f that))
+ (and (contract-struct-stronger? (base-parameter/c-in that)
+ (base-parameter/c-in this))
+ (contract-struct-stronger? (base-parameter/c-out this)
+ (base-parameter/c-out that)))]
+ [else
+ (contract-struct-equivalent? (base-parameter/c-in this)
+ (base-parameter/c-in that))])))
+
+(define (parameter/c-equivalent this that)
+ (and (base-parameter/c? that)
+ (cond
+ [(or (base-parameter/c-out/f this)
+ (base-parameter/c-out/f that))
+ (and (contract-struct-equivalent? (base-parameter/c-in this)
+ (base-parameter/c-in that))
+ (contract-struct-equivalent? (base-parameter/c-out this)
+ (base-parameter/c-out that)))]
+ [else
+ (contract-struct-equivalent? (base-parameter/c-in this)
+ (base-parameter/c-in that))])))
+
;; in - negative contract
-;; out - positive contract
-;; both-supplied? - for backwards compat printing
-(define-struct parameter/c (in out both-supplied?)
- #:property prop:custom-write custom-write-property-proc
+;; out - positive contract or #f
+;; out is #f if it was not supplied to `parameter/c`
+(struct base-parameter/c (in out/f)
+ #:property prop:custom-write custom-write-property-proc)
+
+(define (base-parameter/c-out b-p/c)
+ (or (base-parameter/c-out/f b-p/c)
+ (base-parameter/c-in b-p/c)))
+
+(struct impersonator-parameter/c base-parameter/c ()
#:omit-define-syntaxes
#:property prop:contract
(build-contract-property
#:trusted trust-me
- #:late-neg-projection
- (λ (ctc)
- (define in-proc (get/build-late-neg-projection (parameter/c-in ctc)))
- (define out-proc (get/build-late-neg-projection (parameter/c-out ctc)))
- (λ (blame)
- (define blame/c (blame-add-context blame "the parameter of"))
- (define in-proj (in-proc (blame-swap blame/c)))
- (define out-proj (out-proc blame/c))
- (λ (val neg-party)
- (define blame+neg-party (cons blame/c neg-party))
- (cond
- [(parameter? val)
- (define (add-profiling f)
- (λ (x)
- (with-contract-continuation-mark
- blame+neg-party
- (f x neg-party))))
- ;; TODO this ought to have the `contracted` property, but it's not a chaperone...
- (make-derived-parameter
- val
- (add-profiling in-proj)
- (add-profiling out-proj))]
- [else
- (raise-blame-error blame #:missing-party neg-party
- val '(expected "a parameter"))]))))
+ #:late-neg-projection parameter/c-lnp
+ #:name parameter/c-name
+ #:first-order parameter/c-first-order
+ #:stronger parameter/c-stronger
+ #:equivalent parameter/c-equivalent))
- #:name
- (λ (ctc) (apply build-compound-type-name
- `(parameter/c ,(parameter/c-in ctc)
- ,@(if (parameter/c-both-supplied? ctc)
- (list (parameter/c-out ctc))
- (list)))))
- #:first-order
- (λ (ctc)
- (let ([tst (contract-first-order (parameter/c-out ctc))])
- (λ (x)
- (and (parameter? x)
- (tst (x))))))
-
- #:stronger
- (λ (this that)
- (and (parameter/c? that)
- (and (contract-struct-stronger? (parameter/c-out this)
- (parameter/c-out that))
- (contract-struct-stronger? (parameter/c-in that)
- (parameter/c-in this)))))
- #:equivalent
- (λ (this that)
- (and (parameter/c? that)
- (and (contract-struct-equivalent? (parameter/c-out this)
- (parameter/c-out that))
- (contract-struct-equivalent? (parameter/c-in that)
- (parameter/c-in this)))))))
+(struct chaperone-parameter/c base-parameter/c ()
+ #:property prop:chaperone-contract
+ (build-chaperone-contract-property
+ #:trusted trust-me
+ #:late-neg-projection parameter/c-lnp
+ #:name parameter/c-name
+ #:first-order parameter/c-first-order
+ #:stronger parameter/c-stronger
+ #:equivalent parameter/c-equivalent))
(define (procedure-arity-includes-equivalent? this that)
(and (procedure-arity-includes/c? that)