diff --git a/.Rbuildignore b/.Rbuildignore
index 7ee683ae..e1944324 100644
--- a/.Rbuildignore
+++ b/.Rbuildignore
@@ -23,3 +23,4 @@
 ^\.claude$
 ^\.git-blame-ignore-revs$
 ^AGENTS\.md$
+^\.lintr\.R$
diff --git a/.lintr.R b/.lintr.R
new file mode 100644
index 00000000..eac429f6
--- /dev/null
+++ b/.lintr.R
@@ -0,0 +1 @@
+linters <- lintr::linters_with_defaults()
diff --git a/NAMESPACE b/NAMESPACE
index 713dcf05..6e485aaa 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -42,6 +42,7 @@ export("S7_data<-")
 export("method<-")
 export("prop<-")
 export("props<-")
+export(S4_contains)
 export(S4_register)
 export(S7_class)
 export(S7_class_desc)
diff --git a/NEWS.md b/NEWS.md
index 6c34bdcc..244ba7f1 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -2,6 +2,7 @@
 
 * New `:=` operator creates and names an object in one step, so `Foo := new_class()` is equivalent to `Foo <- new_class(name = "Foo")` (#658).
 * The class object that S7 stores on each instance now lives in the `_S7_class` attribute (previously `S7_class`), moving it into the `_`-prefixed namespace reserved for S7 internals so it can't collide with a user-defined property. Objects created by an older version of S7 (e.g. serialised to disk or baked into another package's lazy-load database) continue to work, as S7 falls back to the old attribute name when reading them (#677).
+* S7 and S4 now interoperate through inheritance. `new_class()` can use an S4 class as a parent, mapping S4 slots to S7 properties and registering the class with S4 automatically. Conversely, `S4_register()` registers an S7 class with S4, and `S4_contains()` returns an S4 class name suitable for `methods::setClass(contains = )`, exposing stored S7 properties as S4 slots for S4 subclasses. This support includes S4 initialization and validity integration, and S4/internal generic registration where needed; see `vignette("compatibility")` for caveats (#456).
 * Errors thrown by S7 now report the function where they occurred, making it easier to track down the source of a problem (#646).
 * `class_POSIXct` uses the `tzone` attribute (not `tz`), and allows it to be absent (#401).
 * Base type wrappers like `class_integer` now define their constructor and validator in the S7 namespace. (#553).
diff --git a/R/S4.R b/R/S4.R
index a1814e78..b97666cc 100644
--- a/R/S4.R
+++ b/R/S4.R
@@ -1,13 +1,34 @@
-#' Register an S7 or S3 class with S4
+#' Register an S7, S3, or union class with S4
 #'
 #' If you want to use [method<-] to register a method for an S4 generic with
-#' an S7 class or an S3 class (created by [new_S3_class()]), you need to call
-#' `S4_register()` once.
+#' an S7 class that does not extend an S4 class, or an S3 class created by
+#' [new_S3_class()], you need to call `S4_register()` once. Classes created by
+#' [new_class()] with an S4 parent are registered automatically.
 #'
-#' @param class An S7 class created with [new_class()], or an S3 class created
-#'   with [new_S3_class()].
+#' @section Details:
+#' `S4_register()` registers an S7 class, S3 class, or S7 union with S4 and
+#' invisibly returns the registered S4 class name.
+#' For S7 classes, this creates a virtual S4 old class that exposes stored S7
+#' properties as S4 slots and carries the `_S7_class` slot needed for S7 dispatch
+#' and validation.
+#'
+#' After registration, `S4_contains()` returns the virtual S4 class name to use
+#' when an S4 class should extend an S7 class with
+#' `methods::setClass(contains = )`. It asserts that the S7 properties can
+#' safely cross the S4 inheritance boundary.
+#'
+#' Register S7 unions with `S4_register()` before using them in S4 slots or
+#' method signatures unless an equivalent S4 union already exists.
+#'
+#' See `vignette("compatibility")` for examples and caveats.
+#'
+#' @param class An S7 class created with [new_class()], or, for
+#'   `S4_register()` only, an S3 class created with [new_S3_class()] or an S7
+#'   union created with [new_union()].
 #' @param env Expert use only. Environment where S4 class will be registered.
-#' @returns Nothing; the function is called for its side-effect.
+#' @returns
+#' Called for its side effects and invisibly returns the registered S4 class
+#' name.
 #' @export
 #' @examples
 #' methods::setGeneric("S4_generic", function(x) {
@@ -19,23 +40,445 @@
 #' method(S4_generic, Foo) <- function(x) "Hello"
 #'
 #' S4_generic(Foo())
+#'
+#' S4Foo := new_class(properties = list(x = class_numeric), package = "S7")
+#' S4_register(S4Foo)
+#' methods::setClass("S4Child", contains = S4_contains(S4Foo))
 S4_register <- function(class, env = parent.frame()) {
-  if (is_class(class)) {
-    classes <- class_dispatch(class)
+  where <- topenv(env)
+  if (is_union(class)) {
+    return(invisible(S4_register_union(class, where)))
+  } else if (is_class(class)) {
+    return(invisible(S4_register_class(class, where)))
   } else if (is_S3_class(class)) {
     classes <- class$class
+    methods::setOldClass(classes, where = where)
+    return(invisible(classes[1L]))
   } else {
     msg <- sprintf(
-      "`class` must be an S7 class or an S3 class, not a %s.",
+      "`class` must be an S7 class, S3 class, or S7 union, not a %s.",
       obj_desc(class)
     )
     stop2(msg)
   }
+}
+
+#' @rdname S4_register
+#' @export
+S4_contains <- function(class, env = parent.frame()) {
+  where <- topenv(env)
+  if (!is_class(class)) {
+    msg <- sprintf("`class` must be an S7 class, not a %s.", obj_desc(class))
+    stop2(msg)
+  }
+
+  class_name <- as.character(
+    S4_registered_class(class, where, call = sys.call())@className
+  )
+  S4_check_contains(class)
+  class_name
+}
+
+S4_register_union <- function(class, env) {
+  name <- S4_union_name(class, env)
+  methods::setClassUnion(
+    name,
+    vcapply(class$classes, S4_class, S4_env = env),
+    where = env
+  )
+  name
+}
+
+S4_class <- function(x, S4_env, call = sys.call(-1L)) {
+  switch(
+    class_type(x),
+    `NULL` = "NULL",
+    missing = "missing",
+    any = "ANY",
+    S7_base = base_to_S4(x$class),
+    S4 = as.character(x@className),
+    S7 = as.character(
+      S4_registered_class(x, S4_env, call = call)@className
+    ),
+    S7_S3 = as.character(
+      S4_registered_class(x, S4_env, call = call)@className
+    ),
+    S7_union = S4_union_class(x, S4_env)
+  )
+}
+
+# S4 dispatch uses `class()` to find a method, but `class(1.5)` is "numeric",
+# not "double", so registering under "double" silently misses real doubles.
+# Mapping to "numeric" catches doubles but also matches integers too. There's
+# no clean S4 way to say "doubles only" and this seems likely to be what
+# people want.
+base_to_S4 <- function(class) {
+  switch(class, double = "numeric", class)
+}
+
+S4_registered_class <- function(x, S4_env, call = sys.call(-1L)) {
+  class <- tryCatch(
+    methods::getClass(class_register(x), where = S4_env),
+    error = function(err) NULL
+  )
+  if (is.null(class)) {
+    msg <- sprintf(
+      "Class has not been registered with S4; please call S4_register(%s).",
+      class_deparse(x)
+    )
+    stop2(msg, call = call)
+  }
+  class
+}
+
+S4_union_class <- function(x, S4_env) {
+  if (identical(x, class_numeric)) {
+    return("numeric")
+  }
+
+  name <- S4_union_name(x, S4_env)
+  if (methods::isClass(name, where = S4_env)) {
+    return(name)
+  }
+
+  name <- S4_find_union(x, S4_env)
+  if (!is.null(name)) {
+    return(name)
+  }
+
+  msg <- sprintf(
+    "Class union has not been registered with S4; please call S4_register(%s).",
+    class_deparse(x)
+  )
+  stop(msg, call. = FALSE)
+}
+
+S4_union_name <- function(x, S4_env) {
+  paste0(vcapply(x$classes, S4_class, S4_env = S4_env), collapse = "_OR_")
+}
+
+S4_find_union <- function(x, S4_env) {
+  members <- vcapply(x$classes, S4_class, S4_env = S4_env)
+  supers <- lapply(members, S4_direct_superclasses, S4_env = S4_env)
+  candidates <- base::Reduce(base::intersect, supers)
+  matches <- base::Filter(
+    function(candidate) S4_union_matches(candidate, members, S4_env),
+    candidates
+  )
+  if (length(matches) == 0) {
+    return(NULL)
+  }
+
+  matches[1L]
+}
+
+S4_direct_superclasses <- function(class, S4_env) {
+  class <- methods::getClass(class, where = S4_env)
+  contains <- class@contains
+  contains <- base::Filter(function(x) x@distance == 1, contains)
+  names(contains)
+}
+
+S4_union_matches <- function(class, members, S4_env) {
+  class <- methods::getClass(class, where = S4_env)
+  if (!methods::isClassUnion(class)) {
+    return(FALSE)
+  }
+
+  setequal(S4_union_members(class), members)
+}
+
+S4_union_members <- function(class) {
+  subclasses <- base::Filter(function(x) x@distance == 1, class@subclasses)
+  vcapply(subclasses, function(x) as.character(x@subClass))
+}
+
+S4_ancestor <- function(class) {
+  parent_class <- attr(class, "parent", exact = TRUE)
+  while (is_class(parent_class)) {
+    parent_class <- attr(parent_class, "parent", exact = TRUE)
+  }
+  if (is_S4_class(parent_class)) parent_class
+}
+
+S7_extends_S4 <- function(class) {
+  !is.null(S4_ancestor(class))
+}
+
+inherits_S4 <- function(x) {
+  isS4(x) ||
+    {
+      klass <- S7_class(x)
+      !is.null(klass) && S7_extends_S4(klass)
+    }
+}
+
+S4_register_subclass <- function(class, env) {
+  S4_register(class, env)
+  invisible()
+}
+
+S4_set_S3_class_prototype <- function(class, S3_class, env) {
+  class_def <- methods::getClass(class, where = env)
+  attr(class_def@prototype, ".S3Class") <- S3_class
+  methods:::assignClassDef(class, class_def, env)
+  invisible(class)
+}
+
+S4_slot_names <- function(class, S4_env) {
+  names(methods::getClass(class, where = S4_env)@slots)
+}
+
+S4_property_class <- function(prop, S4_env) {
+  S4_class(prop$class, S4_env)
+}
+
+S4_check_contains <- function(class, call = sys.call(-1L)) {
+  if (!is_class(class)) {
+    return(invisible())
+  }
+
+  for (prop in class@properties) {
+    if (prop_is_dynamic(prop) || prop_has_setter(prop)) {
+      msg <- sprintf(
+        paste0(
+          "Can't extend S7 class %s with S4 because property %s has a ",
+          "custom %s."
+        ),
+        class_desc(class),
+        prop$name,
+        if (prop_is_dynamic(prop)) "getter" else "setter"
+      )
+      stop2(msg, call = call)
+    }
+  }
 
-  methods::setOldClass(classes, where = topenv(env))
   invisible()
 }
 
+S4_properties_prototype <- function(
+  properties,
+  class,
+  env,
+  include_S7_class = FALSE
+) {
+  args <- list()
+  for (name in names(properties)) {
+    value <- S4_property_prototype(properties[[name]], env, class@package)
+    if (length(value) != 0L) {
+      args[[name]] <- value[[1L]]
+    }
+  }
+  if (include_S7_class) {
+    args$`_S7_class` <- class
+  }
+  do.call(methods::prototype, args)
+}
+
+S4_property_prototype <- function(prop, env, package) {
+  tryCatch(
+    {
+      value <- prop_default(prop, env, package)
+      if (is.call(value) || is.symbol(value)) {
+        value <- eval(value, env)
+      }
+      list(value)
+    },
+    error = function(cnd) {
+      if (!is.null(prop$default)) {
+        stop(cnd)
+      }
+      list()
+    }
+  )
+}
+
+S4_old_classes <- function(class) {
+  subclasses <- character()
+  while (is_class(class)) {
+    if (class@abstract) {
+      return(subclasses)
+    }
+    subclasses <- c(subclasses, S7_class_name(class))
+    class <- class@parent
+    if (is_S4_class(class)) {
+      return(subclasses)
+    }
+  }
+  character()
+}
+
+S4_register_class <- function(class, env = parent.frame()) {
+  where <- topenv(env)
+  class_name <- S7_class_name(class)
+  parent_class_name <- S4_reified_parent_class(class, where)
+  parent_slot_names <- character()
+  if (!is.null(parent_class_name)) {
+    parent_slot_names <- S4_slot_names(parent_class_name, where)
+  }
+
+  properties <- class@properties
+  properties <- properties[setdiff(names(properties), parent_slot_names)]
+  slots <- lapply(properties, S4_property_class, S4_env = where)
+  needs_S7_class_slot <- !"_S7_class" %in% parent_slot_names
+  if (needs_S7_class_slot) {
+    slots$`_S7_class` <- "S7_class"
+  }
+
+  methods::setClass(
+    Class = class_name,
+    slots = slots,
+    contains = c(parent_class_name, "VIRTUAL"),
+    prototype = S4_properties_prototype(
+      properties,
+      class,
+      where,
+      include_S7_class = TRUE
+    ),
+    where = where
+  )
+
+  if (class@abstract) {
+    return(class_name)
+  }
+
+  old_classes <- S4_reified_old_classes(class)
+  methods::setOldClass(old_classes, S4Class = class_name, where = where)
+  S4_set_S3_class_prototype(class_name, old_classes, where)
+  methods::setValidity(class_name, S4_validate_class, where = where)
+  methods::setMethod("initialize", class_name, S4_initialize, where = where)
+
+  class_name
+}
+
+S4_reified_parent_class <- function(class, env) {
+  parent_class <- class@parent
+  if (is_class(parent_class)) {
+    if (parent_class@name == "S7_object") {
+      return(NULL)
+    }
+    return(S4_register(parent_class, env))
+  } else if (is_S4_class(parent_class)) {
+    return(S4_class(parent_class, env))
+  }
+
+  NULL
+}
+
+S4_reified_old_classes <- function(class) {
+  if (S7_extends_S4(class)) {
+    return(c(S4_old_classes(class), "S7_object"))
+  }
+
+  class_dispatch(class)
+}
+
+S4_validate_class <- function(object) {
+  class_name <- class(object)[1L]
+  class <- S7_class(object)
+
+  if (identical(S7_class_name(class), class_name)) {
+    return(S4_validate(object))
+  }
+  while (is_class(class@parent)) {
+    class <- class@parent
+    if (identical(S7_class_name(class), class_name)) {
+      return(TRUE)
+    }
+  }
+
+  sprintf(
+    "object with S7 class %s does not match S4 class %s",
+    dQuote(S7_class_name(S7_class(object))),
+    dQuote(class_name)
+  )
+}
+
+S4_validate <- function(object) {
+  if (!S7_inherits(object)) {
+    return(sprintf(
+      "object with S4 class %s is not an S7 object",
+      dQuote(class(object)[1L])
+    ))
+  }
+
+  tryCatch(
+    {
+      validate(object)
+      TRUE
+    },
+    error = function(cnd) conditionMessage(cnd)
+  )
+}
+
+S4_initialize <- function(.Object, ...) {
+  if (isS4(.Object) && has_S7_class(.Object)) {
+    S4_check_contains(S7_class(.Object))
+  }
+
+  args <- list(...)
+  if (length(args) == 0) {
+    return(.Object)
+  }
+
+  nms <- names2(args)
+  prop_nms <- prop_names(.Object)
+  vals <- list()
+  data_part <- NULL
+  for (arg in args[nms == ""]) {
+    arg_vals <- S4_initialize_values(arg)
+    if (".Data" %in% names(arg_vals)) {
+      data_part <- arg
+    }
+    arg_vals <- arg_vals[names(arg_vals) %in% prop_nms]
+    vals <- modify_list(vals, arg_vals)
+  }
+  named_args <- args[nms != ""]
+  s4_vals <- list()
+  if (isS4(.Object)) {
+    s4_slot_nms <- setdiff(methods::slotNames(.Object), prop_nms)
+    s4_vals <- named_args[names(named_args) %in% s4_slot_nms]
+    named_args <- named_args[!names(named_args) %in% s4_slot_nms]
+  }
+  vals <- modify_list(vals, named_args)
+  if (".Data" %in% names(named_args)) {
+    data_part <- vals$.Data
+  }
+
+  if (!is.null(data_part)) {
+    .Object <- S4_initialize_data_part(data_part, .Object)
+  }
+
+  props(.Object) <- vals
+  for (name in names(s4_vals)) {
+    methods::slot(.Object, name) <- s4_vals[[name]]
+  }
+  .Object
+}
+
+S4_initialize_values <- function(object) {
+  if (S7_inherits(object)) {
+    props(object)
+  } else if (isS4(object)) {
+    slots <- methods::slotNames(object)
+    stats::setNames(lapply(slots, methods::slot, object = object), slots)
+  } else {
+    attrs <- attributes(object) %||% list()
+    attrs$class <- NULL
+    if (is.object(object)) {
+      attrs$.S3Class <- class(object)
+    }
+    c(list(.Data = unclass(object)), attrs)
+  }
+}
+
+S4_initialize_data_part <- function(value, object) {
+  incoming <- attributes(value) %||% list()
+  incoming$class <- NULL
+  attributes(value) <- modify_list(attributes(object), incoming)
+  value
+}
+
 is_S4_class <- function(x) inherits(x, "classRepresentation")
 
 S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) {
@@ -45,13 +488,13 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) {
   # Convert generator function to class
   if (methods::is(x, "classGeneratorFunction")) {
     return(S4_to_S7_class(
-      methods::getClass(as.character(x@className)),
+      methods::getClass(x@className),
       error_base,
       call = call
     ))
   }
 
-  if (methods::is(x, "ClassUnionRepresentation")) {
+  if (methods::isClassUnion(x)) {
     subclasses <- Filter(function(y) y@distance == 1, x@subclasses)
     subclasses <- lapply(subclasses, function(x) methods::getClass(x@subClass))
     do.call("new_union", subclasses)
@@ -62,8 +505,8 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) {
         return(basic_classes[[x@className]])
       }
     }
-    if (methods::extends(x, "oldClass")) {
-      new_S3_class(as.character(x@className))
+    if (is_oldClass(x)) {
+      new_S3_class(methods::extends(x))
     } else {
       x
     }
@@ -76,6 +519,19 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) {
   }
 }
 
+S4_slot_properties <- function(class) {
+  properties <- Map(S4_slot_property, class@slots, names(class@slots))
+  names(properties) <- names(class@slots)
+  properties
+}
+
+S4_slot_property <- function(class, name) {
+  new_property(
+    class = S4_to_S7_class(methods::getClass(class)),
+    name = name
+  )
+}
+
 S4_basic_classes <- function() {
   list(
     NULL = NULL,
@@ -129,7 +585,8 @@ S4_class_dispatch <- function(x) {
 }
 
 is_oldClass <- function(x) {
-  x@virtual && methods::extends(x, "oldClass") && x@className != "oldClass"
+  methods::extends(x, "oldClass") &&
+    x@className %in% attr(x@prototype, ".S3Class")
 }
 
 S4_class_name <- function(x) {
@@ -189,9 +646,22 @@ find_package_with_symbol <- function(name, env, exclude = NULL) {
 }
 
 S4_remove_classes <- function(classes, where = parent.frame()) {
+  where <- topenv(where)
   for (class in classes) {
-    suppressWarnings(methods::removeClass(class, topenv(where)))
+    if (methods::isClass(class, where = where)) {
+      methods::removeClass(class, where)
+    }
   }
 }
 
-globalVariables(c("superClass", "virtual"))
+globalVariables(c(
+  ".Data",
+  "className",
+  "distance",
+  "package",
+  "prototype",
+  "slots",
+  "subClass",
+  "superClass",
+  "virtual"
+))
diff --git a/R/class-spec.R b/R/class-spec.R
index 3367f8dd..ef20b9f7 100644
--- a/R/class-spec.R
+++ b/R/class-spec.R
@@ -82,6 +82,15 @@ class_type <- function(x) {
   }
 }
 
+class_properties <- function(x) {
+  switch(
+    class_type(x),
+    S7 = attr(x, "properties", exact = TRUE) %||% list(),
+    S4 = S4_slot_properties(x),
+    list()
+  )
+}
+
 class_friendly <- function(x) {
   switch(
     class_type(x),
@@ -207,12 +216,17 @@ class_constructor <- function(.x) {
 }
 
 class_validate <- function(class, object) {
+  if (is_S4_class(class)) {
+    if (isS4(object)) {
+      check <- methods::validObject(object, test = TRUE)
+      return(if (isTRUE(check)) NULL else check)
+    } else {
+      return(NULL)
+    }
+  }
+
   validator <- switch(
     class_type(class),
-    S4 = function(object) {
-      check <- methods::validObject(object, test = TRUE)
-      if (isTRUE(check)) NULL else check
-    },
     S7 = class@validator,
     S7_base = class$validator,
     S7_S3 = class$validator,
@@ -274,7 +288,11 @@ class_dispatch <- function(x) {
     missing = "MISSING",
     any = character(),
     S4 = S4_class_dispatch(methods::extends(x)),
-    S7 = c(S7_class_name(x), class_dispatch(x@parent)),
+    S7 = c(
+      S7_class_name(x),
+      class_dispatch(x@parent),
+      if (is_S4_class(x@parent)) "S7_object"
+    ),
     S7_base = c(x$class, "S7_object"),
     S7_S3 = c(x$class, "S7_object"),
     S7_external = class_dispatch(resolve_external_class_req(x)),
@@ -329,8 +347,8 @@ class_inherits <- function(x, what) {
     "NULL" = is.null(x),
     missing = FALSE,
     any = TRUE,
-    S4 = isS4(x) && methods::is(x, what),
-    S7 = inherits(x, "S7_object") && inherits(x, S7_class_name(what)),
+    S4 = methods::is(x, what),
+    S7 = has_S7_class(x) && inherits(x, S7_class_name(what)),
     S7_base = what$class == base_class(x),
     S7_union = some(what$classes, class_inherits, x = x),
     S7_S3 = !isS4(x) && class_dispatch_extends(what$class, class(x)),
@@ -390,10 +408,10 @@ class_extends <- function(child, parent) {
 obj_type <- function(x) {
   if (identical(x, quote(expr = ))) {
     "missing"
-  } else if (inherits(x, "S7_object")) {
-    "S7"
   } else if (isS4(x)) {
     "S4"
+  } else if (has_S7_class(x)) {
+    "S7"
   } else if (is.object(x)) {
     "S3"
   } else {
diff --git a/R/class.R b/R/class.R
index 4cbf99bf..d1011d13 100644
--- a/R/class.R
+++ b/R/class.R
@@ -15,9 +15,10 @@
 #'   `Foo := new_class(...)`. This object both represents the class and is used
 #'   to construct new instances of the class.
 #' @param parent The parent class to inherit behavior from.
-#'   There are three options:
+#'   There are four options:
 #'
 #'   * An S7 class, like [S7_object].
+#'   * An S4 class, like the result of [methods::getClass()].
 #'   * An S3 class wrapped by [new_S3_class()].
 #'   * A base type, like [class_logical], [class_integer], etc.
 #' @param package Package name. This is automatically resolved if the class is
@@ -55,6 +56,17 @@
 #'   belong to each instance of the class. Each element of the list can
 #'   either be a type specification (processed by [as_class()]) or a
 #'   full property specification created [new_property()].
+#' @section S4 compatibility:
+#' `new_class()` can use an S4 class definition or class generator as its
+#' `parent`. S4 parent slots become S7 properties, the class is registered with
+#' S4 automatically, and S4 generics can dispatch through the S4 parent.
+#'
+#' S7 objects that directly extend S4 are represented as S3 old-class objects,
+#' so `isS4()` is `FALSE` even though [methods::is()] and S4 dispatch see the
+#' S4 parent. S4 classes can extend S7 classes by calling
+#' [S4_contains()] in `methods::setClass(contains = )`.
+#'
+#' See `vignette("compatibility")` for examples and caveats.
 #' @return A object constructor, a function that can be used to create objects
 #'   of the given class.
 #' @export
@@ -125,22 +137,28 @@ new_class <- function(
     }
     if (
       abstract &&
-        (!is_class(parent) || !(parent@abstract || parent@name == "S7_object"))
+        !((is_class(parent) &&
+          (parent@abstract || parent@name == "S7_object")) ||
+          (is_S4_class(parent) && parent@virtual))
     ) {
       stop2("Abstract classes must have abstract parents.")
     }
   }
 
-  # Combine properties from parent, overriding as needed
-  parent_props <- attr(parent, "properties", exact = TRUE) %||% list()
+  parent_props <- class_properties(parent)
   new_props <- as_properties(properties)
   check_prop_names(new_props)
   check_prop_overrides(new_props, parent_props, name, parent)
 
+  # Combine properties from parent, overriding as needed
+  all_props <- parent_props
+  all_props[names(new_props)] <- new_props
+
   if (is.null(constructor)) {
+    constructor_props <- if (is_S4_class(parent)) all_props else new_props
     constructor <- new_constructor(
       parent,
-      new_props,
+      constructor_props,
       envir = parent.frame(),
       package = package
     )
@@ -151,13 +169,17 @@ new_class <- function(
   attr(object, "name") <- name
   attr(object, "parent") <- parent
   attr(object, "package") <- package
-  attr(object, "properties") <- modify_list(parent_props, new_props)
+  attr(object, "properties") <- all_props
   attr(object, "abstract") <- abstract
   attr(object, "constructor") <- constructor
   attr(object, "validator") <- validator
   class(object) <- c("S7_class", "S7_object")
 
-  global_variables(names(new_props))
+  if (S7_extends_S4(object)) {
+    S4_register_subclass(object, env = parent.frame())
+  }
+
+  global_variables(names(all_props))
   object
 }
 globalVariables(c(
@@ -249,7 +271,9 @@ c.S7_class <- function(...) {
   stop2("Can not combine S7 class objects.")
 }
 
-can_inherit <- function(x) is_base_class(x) || is_S3_class(x) || is_class(x)
+can_inherit <- function(x) {
+  is_base_class(x) || is_S3_class(x) || is_class(x) || is_S4_class(x)
+}
 
 check_can_inherit <- function(
   x,
@@ -258,7 +282,7 @@ check_can_inherit <- function(
 ) {
   if (!can_inherit(x)) {
     msg <- sprintf(
-      "`%s` must be an S7 class, S3 class, or base type, not %s.",
+      "`%s` must be an S7 class, S4 class, S3 class, or base type, not %s.",
       arg,
       class_friendly(x)
     )
@@ -294,6 +318,13 @@ check_parent <- function(parent, class, call = sys.call(-1L)) {
     return()
   }
 
+  # S4 parent compatibility is checked after new_object() installs the S7
+  # class attributes, at which point methods::validObject() can see the
+  # registered oldClass structure.
+  if (is_S4_class(parent_class)) {
+    return()
+  }
+
   if (class_inherits(parent, parent_class)) {
     return()
   }
@@ -426,7 +457,11 @@ S7_class <- function(object) {
     obj_type(object),
     missing = class_missing,
     S7 = .Call(S7_class_, object),
-    S4 = methods::getClass(class(object)),
+    S4 = if (has_S7_class(object)) {
+      .Call(S7_class_, object)
+    } else {
+      methods::getClass(class(object))
+    },
     S3 = new_S3_class(class(object)),
     base = base_S7_class(object)
   )
diff --git a/R/constructor.R b/R/constructor.R
index 528ae371..86e8403c 100644
--- a/R/constructor.R
+++ b/R/constructor.R
@@ -6,7 +6,11 @@ new_constructor <- function(
 ) {
   properties <- as_properties(properties)
 
-  if (identical(parent, S7_object) || (is_class(parent) && parent@abstract)) {
+  if (
+    identical(parent, S7_object) ||
+      is_S4_class(parent) ||
+      (is_class(parent) && parent@abstract)
+  ) {
     # There's no parent constructor to delegate to, so the constructor must
     # handle all properties: inherited and newly declared (which win).
     all_props <- modify_list(
@@ -17,11 +21,21 @@ new_constructor <- function(
     arg_info <- constructor_args(parent, all_props, envir, package)
     self_args <- as_names(names(arg_info$self))
 
+    s4_data_part <- is_S4_class(parent) && ".Data" %in% names(parent@slots)
+    parent_call <- if (s4_data_part) {
+      bquote(
+        methods::getClass(.(as.character(parent@className)))@prototype@.Data
+      )
+    } else if (has_S7_symbols(envir, "S7_object")) {
+      quote(S7_object())
+    } else {
+      quote(S7::S7_object())
+    }
     new_object_call <-
-      if (has_S7_symbols(envir, "new_object", "S7_object")) {
-        bquote(new_object(S7_object(), ..(self_args)), splice = TRUE)
+      if (has_S7_symbols(envir, "new_object")) {
+        bquote(new_object(.(parent_call), ..(self_args)), splice = TRUE)
       } else {
-        bquote(S7::new_object(S7::S7_object(), ..(self_args)), splice = TRUE)
+        bquote(S7::new_object(.(parent_call), ..(self_args)), splice = TRUE)
       }
 
     return(new_function(
diff --git a/R/convert.R b/R/convert.R
index 97d81324..e2abf2c4 100644
--- a/R/convert.R
+++ b/R/convert.R
@@ -128,6 +128,8 @@ convert <- function(from, to, ...) {
     convert_down(from, to, dots)
   } else if (is_base_class(to)) {
     base_coerce(from, to, ...)
+  } else if (is_S4_coerce(from, to)) {
+    convert_S4(from, to, ...)
   } else {
     msg <- paste_c(
       "Can't find method with dispatch classes:\n",
@@ -188,6 +190,8 @@ convert_up <- function(from, to, call = sys.call(-1L)) {
     from <- zap_attr(from, c(setdiff(from_props, to_props), "S7_class"))
     attr(from, "_S7_class") <- to
     class(from) <- class_dispatch(to)
+  } else if (is_S4_coerce(from, to)) {
+    from <- convert_S4(from, to)
   } else {
     stop2("Unreachable.")
   }
@@ -229,6 +233,22 @@ convert_down <- function(from, to, user_args = list()) {
   do.call(to, constructor_args)
 }
 
+s4_to_name <- function(x) {
+  if (is_S4_class(x)) x@className else class_register(x)
+}
+
+is_S4_coerce <- function(from, to) {
+  # can loosen this restriction once convert() has default base targets
+  if (!inherits_S4(from) && !is_S4_class(to)) {
+    return(FALSE)
+  }
+  methods::canCoerce(from, s4_to_name(to))
+}
+
+convert_S4 <- function(from, to, ...) {
+  methods::as(from, s4_to_name(to), ...)
+}
+
 # Converted to S7_generic onLoad in order to avoid dependency between files
 on_load_make_convert_generic <- function() {
   convert <<- S7_generic(
diff --git a/R/inherits.R b/R/inherits.R
index adb55887..5dfb269e 100644
--- a/R/inherits.R
+++ b/R/inherits.R
@@ -40,12 +40,18 @@
 S7_inherits <- function(x, class = NULL) {
   class <- as_class(class)
   if (is.null(class)) {
-    inherits(x, "S7_object")
+    has_S7_class(x)
   } else {
     class_inherits(x, class)
   }
 }
 
+has_S7_class <- function(x) {
+  identical(class(x), "S7_object") ||
+    inherits(x, "S7_class") ||
+    !is.null(.Call(S7_class_, x))
+}
+
 #' @export
 #' @rdname S7_inherits
 # called from src/prop.c
diff --git a/R/method-register-S3.R b/R/method-register-S3.R
index 42e7e614..2c9f0a5c 100644
--- a/R/method-register-S3.R
+++ b/R/method-register-S3.R
@@ -29,6 +29,10 @@ register_S3_method <- function(
     envir <- environment(generic$generic) %||% envir
     registerS3method(generic$name, class, method, envir)
   }
+
+  if (should_register_S4_method(generic, signature)) {
+    register_S4_method(generic$name, signature, method, envir, call = call)
+  }
 }
 
 # `registerS3method()` registers into the S3 methods table of
diff --git a/R/method-register-S4.R b/R/method-register-S4.R
index 1e083cb2..170e20da 100644
--- a/R/method-register-S4.R
+++ b/R/method-register-S4.R
@@ -10,47 +10,40 @@ register_S4_method <- function(
   methods::setMethod(generic, S4_signature, method, where = S4_env)
 }
 
-S4_class <- function(x, S4_env, call = sys.call(-1L)) {
-  switch(
-    class_type(x),
-    `NULL` = "NULL",
-    missing = "missing",
-    any = "ANY",
-    S7_base = base_to_S4(x$class),
-    S4 = x,
-    S7 = S4_registered_class(x, S4_env = S4_env, call = call),
-    S7_S3 = S4_registered_class(x, S4_env = S4_env, call = call),
-    S7_union = stop2(
-      "Internal error: union should be flattened upstream.",
-      call = NULL
-    )
-  )
+should_register_S4_method <- function(generic, signature) {
+  is_internal_generic(generic$name) && signature_has_S4_ancestor(signature)
 }
 
-# S4 dispatch uses `class()` to find a method, but `class(1.5)` is "numeric",
-# not "double", so registering under "double" silently misses real doubles.
-# Mapping to "numeric" catches doubles but also matches integers too. There's
-# no clean S4 way to say "doubles only" and this seems likely to be what
-# people want.
-base_to_S4 <- function(class) {
-  switch(class, double = "numeric", class)
+signature_has_S4_ancestor <- function(signature) {
+  any(vlapply(signature, class_has_S4_ancestor))
 }
 
-S4_registered_class <- function(
-  x,
-  S4_env,
-  call = sys.call(-1L)
-) {
-  class <- tryCatch(
-    methods::getClass(class_register(x), where = S4_env),
-    error = function(err) NULL
+class_has_S4_ancestor <- function(class) {
+  switch(
+    class_type(class),
+    S4 = TRUE,
+    S7 = S7_extends_S4(class),
+    FALSE
   )
-  if (is.null(class)) {
-    msg <- sprintf(
-      "Class has not been registered with S4; please call S4_register(%s).",
-      class_deparse(x)
-    )
-    stop2(msg, call = call)
+}
+
+S3_generic_S4_signature <- function(generic) {
+  if (
+    !(is_S3_generic(generic) || is_external_S3_generic(generic)) ||
+      !is_internal_generic(generic$name)
+  ) {
+    return(NULL)
+  }
+
+  generic <- methods::getGeneric(generic$name)
+  if (is.null(generic) || !is_S4_generic(generic)) {
+    return(NULL)
   }
-  class
+
+  generic@signature
+}
+
+is_external_S3_generic <- function(generic) {
+  is_external_generic(generic) &&
+    identical(generic$dispatch_args, "__S3__")
 }
diff --git a/R/method-register.R b/R/method-register.R
index 8d5f1ee7..93ffde90 100644
--- a/R/method-register.R
+++ b/R/method-register.R
@@ -264,10 +264,18 @@ as_signature <- function(signature, generic, call = sys.call(-1L)) {
   }
 
   n <- generic_n_dispatch(generic)
+
+  if (is_plain_list(signature)) {
+    S4_signature <- S3_generic_S4_signature(generic)
+    if (length(signature) == length(S4_signature)) {
+      n <- length(S4_signature)
+    }
+  }
+
   if (n == 1) {
     # Accept a bare list of length 1 too, for symmetry with multi-dispatch
     # generics where a list is required (#555).
-    if (is.list(signature) && !is.object(signature) && length(signature) == 1) {
+    if (is_plain_list(signature) && length(signature) == 1) {
       signature <- signature[[1]]
     }
     new_signature(list(as_class(signature, arg = "signature")))
diff --git a/R/property.R b/R/property.R
index dc3d62ba..948146bd 100644
--- a/R/property.R
+++ b/R/property.R
@@ -364,7 +364,15 @@ prop_call <- function(object, name) {
 `@.S7_object` <- prop
 
 #' @rawNamespace S3method("@<-",S7_object)
-`@<-.S7_object` <- `prop<-`
+`@<-.S7_object` <- function(object, name, value) {
+  if (isS4(object) && !name %in% names(S7_class(object)@properties)) {
+    methods::slot(object, name) <- value
+    return(object)
+  }
+
+  prop(object, name) <- value
+  object
+}
 
 
 #' Property introspection
diff --git a/R/utils.R b/R/utils.R
index cab73e2a..b83f0cf8 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -243,6 +243,9 @@ deparse_trunc <- function(x, width, collapse = "\n") {
   x
 }
 
+is_plain_list <- function(x) {
+  is.list(x) && !is.object(x)
+}
 
 # For older versions of R ----------------------------------------------------
 deparse1 <- function(expr, collapse = " ", width.cutoff = 500L, ...) {
diff --git a/R/valid.R b/R/valid.R
index 86dbf7ef..71d62ba4 100644
--- a/R/valid.R
+++ b/R/valid.R
@@ -66,7 +66,7 @@
 validate <- function(object, recursive = TRUE, properties = TRUE) {
   check_is_S7(object)
 
-  parent <- if (!recursive) S7_class(object)@parent
+  parent <- validate_parent(object, recursive)
   validate_from(
     object,
     parent = parent,
@@ -75,6 +75,18 @@ validate <- function(object, recursive = TRUE, properties = TRUE) {
   )
 }
 
+validate_parent <- function(object, recursive) {
+  if (!recursive) {
+    return(S7_class(object)@parent)
+  }
+
+  if (isS4(object) && has_S7_class(object)) {
+    return(S4_ancestor(S7_class(object)) %||% S7_object)
+  }
+
+  NULL
+}
+
 # validates `object` assuming `parent` (if supplied) has been validated
 validate_from <- function(
   object,
diff --git a/R/zzz.R b/R/zzz.R
index 5b9bc2fe..a9794809 100644
--- a/R/zzz.R
+++ b/R/zzz.R
@@ -22,6 +22,7 @@ S7_object <- new_class(
   }
 )
 methods::setOldClass("S7_object")
+methods::setOldClass(c("S7_class", "S7_object"))
 
 .S7_type <- NULL
 # Defined onLoad because it depends on R version
diff --git a/man/S4_register.Rd b/man/S4_register.Rd
index 14766a99..6b641b79 100644
--- a/man/S4_register.Rd
+++ b/man/S4_register.Rd
@@ -2,24 +2,49 @@
 % Please edit documentation in R/S4.R
 \name{S4_register}
 \alias{S4_register}
-\title{Register an S7 or S3 class with S4}
+\alias{S4_contains}
+\title{Register an S7, S3, or union class with S4}
 \usage{
 S4_register(class, env = parent.frame())
+
+S4_contains(class, env = parent.frame())
 }
 \arguments{
-\item{class}{An S7 class created with \code{\link[=new_class]{new_class()}}, or an S3 class created
-with \code{\link[=new_S3_class]{new_S3_class()}}.}
+\item{class}{An S7 class created with \code{\link[=new_class]{new_class()}}, or, for
+\code{S4_register()} only, an S3 class created with \code{\link[=new_S3_class]{new_S3_class()}} or an S7
+union created with \code{\link[=new_union]{new_union()}}.}
 
 \item{env}{Expert use only. Environment where S4 class will be registered.}
 }
 \value{
-Nothing; the function is called for its side-effect.
+Called for its side effects and invisibly returns the registered S4 class
+name.
 }
 \description{
 If you want to use \link{method<-} to register a method for an S4 generic with
-an S7 class or an S3 class (created by \code{\link[=new_S3_class]{new_S3_class()}}), you need to call
-\code{S4_register()} once.
+an S7 class that does not extend an S4 class, or an S3 class created by
+\code{\link[=new_S3_class]{new_S3_class()}}, you need to call \code{S4_register()} once. Classes created by
+\code{\link[=new_class]{new_class()}} with an S4 parent are registered automatically.
+}
+\section{Details}{
+
+\code{S4_register()} registers an S7 class, S3 class, or S7 union with S4 and
+invisibly returns the registered S4 class name.
+For S7 classes, this creates a virtual S4 old class that exposes stored S7
+properties as S4 slots and carries the \code{_S7_class} slot needed for S7 dispatch
+and validation.
+
+After registration, \code{S4_contains()} returns the virtual S4 class name to use
+when an S4 class should extend an S7 class with
+\code{methods::setClass(contains = )}. It asserts that the S7 properties can
+safely cross the S4 inheritance boundary.
+
+Register S7 unions with \code{S4_register()} before using them in S4 slots or
+method signatures unless an equivalent S4 union already exists.
+
+See \code{vignette("compatibility")} for examples and caveats.
 }
+
 \examples{
 methods::setGeneric("S4_generic", function(x) {
   standardGeneric("S4_generic")
@@ -30,4 +55,9 @@ S4_register(Foo)
 method(S4_generic, Foo) <- function(x) "Hello"
 
 S4_generic(Foo())
+
+S4Foo := new_class(properties = list(x = class_numeric), package = "S7")
+S4_register(S4Foo)
+S4Foo_S4 <- S4_contains(S4Foo)
+methods::setClass("S4Child", contains = S4Foo_S4)
 }
diff --git a/man/new_class.Rd b/man/new_class.Rd
index b5a3251b..304cbda7 100644
--- a/man/new_class.Rd
+++ b/man/new_class.Rd
@@ -27,9 +27,10 @@ with this name, i.e. \code{Foo <- new_class("Foo", ...)} or
 to construct new instances of the class.}
 
 \item{parent}{The parent class to inherit behavior from.
-There are three options:
+There are four options:
 \itemize{
 \item An S7 class, like \link{S7_object}.
+\item An S4 class, like the result of \code{\link[methods:getClass]{methods::getClass()}}.
 \item An S3 class wrapped by \code{\link[=new_S3_class]{new_S3_class()}}.
 \item A base type, like \link{class_logical}, \link{class_integer}, etc.
 }}
@@ -92,6 +93,20 @@ when an object is passed to a generic.
 
 Learn more in \code{vignette("classes-objects")}
 }
+\section{S4 compatibility}{
+
+\code{new_class()} can use an S4 class definition or class generator as its
+\code{parent}. S4 parent slots become S7 properties, the class is registered with
+S4 automatically, and S4 generics can dispatch through the S4 parent.
+
+S7 objects that directly extend S4 are represented as S3 old-class objects,
+so \code{isS4()} is \code{FALSE} even though \code{\link[methods:is]{methods::is()}} and S4 dispatch see the
+S4 parent. S4 classes can extend S7 classes by calling
+\code{\link[=S4_contains]{S4_contains()}} in \code{methods::setClass(contains = )}.
+
+See \code{vignette("compatibility")} for examples and caveats.
+}
+
 \examples{
 # Create an class that represents a range using a numeric start and end
 Range := new_class(
diff --git a/src/prop.c b/src/prop.c
index 0cd4751f..91045f32 100644
--- a/src/prop.c
+++ b/src/prop.c
@@ -165,11 +165,26 @@ SEXP prop_storage_rename_(SEXP names) {
 }
 
 
+static inline
+SEXP object_class(SEXP object) {
+  if (Rf_isS4(object)) {
+    static SEXP sym_dot_S3Class = NULL;
+    if (sym_dot_S3Class == NULL)
+      sym_dot_S3Class = Rf_install(".S3Class");
+
+    return R_has_slot(object, sym_dot_S3Class) ?
+      R_do_slot(object, sym_dot_S3Class) :
+      R_NilValue;
+  }
+
+  return Rf_getAttrib(object, R_ClassSymbol);
+}
+
 static inline
 Rboolean inherits2(SEXP object, const char* name) {
   // like inherits in R, but iterates over the class STRSXP vector
   // in reverse, since S7_* is typically at the tail.
-  SEXP klass = Rf_getAttrib(object, R_ClassSymbol);
+  SEXP klass = object_class(object);
   if (TYPEOF(klass) == STRSXP) {
     for (int i = Rf_length(klass)-1; i >= 0; i--) {
       if (strcmp(CHAR(STRING_ELT(klass, i)), name) == 0)
@@ -196,6 +211,28 @@ void check_is_S7(SEXP object) {
   signal_is_not_S7(object);
 }
 
+static inline
+SEXP pseudo_null(void) {
+  static SEXP pseudo_NULL = NULL;
+  if (pseudo_NULL == NULL)
+    pseudo_NULL = Rf_install("\001NULL\001");
+  return pseudo_NULL;
+}
+
+static inline
+SEXP prop_get_storage(SEXP object, SEXP name_sym) {
+  SEXP value = Rf_getAttrib(object, name_sym);
+  return value == pseudo_null() ? R_NilValue : value;
+}
+
+static inline
+SEXP prop_set_storage(SEXP object, SEXP name_sym, SEXP value) {
+  if (value == R_NilValue)
+    value = pseudo_null();
+  Rf_setAttrib(object, name_sym, value);
+  return object;
+}
+
 
 static inline
 Rboolean pairlist_contains(SEXP list, SEXP elem) {
@@ -488,7 +525,7 @@ SEXP prop_(SEXP object, SEXP name) {
   }
 
   // try to resolve property from the object attributes
-  SEXP value = Rf_getAttrib(object, prop_storage_sym(name_sym));
+  SEXP value = prop_get_storage(object, prop_storage_sym(name_sym));
 
   // This is commented out because we currently have no way to distinguish between
   // a prop with a value of NULL, and a prop value that is unset/missing.
@@ -573,7 +610,8 @@ SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value) {
     // don't use setter()
     if (should_validate_prop)
       prop_validate(property, value, object, name);
-    Rf_setAttrib(object, prop_storage_sym(name_sym), value);
+    object = PROTECT(prop_set_storage(object, prop_storage_sym(name_sym), value));
+    n_protected++;
   }
 
   if (should_validate_obj)
diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md
index e082b338..dc702afa 100644
--- a/tests/testthat/_snaps/S4.md
+++ b/tests/testthat/_snaps/S4.md
@@ -4,12 +4,12 @@
       S4_register(1)
     Condition
       Error in `S4_register()`:
-      ! `class` must be an S7 class or an S3 class, not a <double>.
+      ! `class` must be an S7 class, S3 class, or S7 union, not a <double>.
     Code
       S4_register("foo")
     Condition
       Error in `S4_register()`:
-      ! `class` must be an S7 class or an S3 class, not a <character>.
+      ! `class` must be an S7 class, S3 class, or S7 union, not a <character>.
 
 # errors on non-S4 classes
 
diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md
index 8d0e9671..2879f3b7 100644
--- a/tests/testthat/_snaps/class.md
+++ b/tests/testthat/_snaps/class.md
@@ -107,24 +107,6 @@
       Error in `new_class()`:
       ! `validator` must be function(self), not function().
 
-# S7 classes can't inherit from S4 or class unions
-
-    Code
-      new_class("test", parent = parentS4)
-    Condition
-      Error in `new_class()`:
-      ! `parent` must be an S7 class, S3 class, or base type, not an S4 class.
-    Code
-      new_class("test", parent = new_union("character"))
-    Condition
-      Error in `as_class()`:
-      ! Can't convert `..1` to a valid class.
-      Class specification must be one of the following, not a <character>:
-       * An S7 class object
-       * An S3 class object (from `new_S3_class()`)
-       * An S4 class object
-       * A base class
-
 # inheritance doesn't let child properties widen or change the parent's type
 
     Code
@@ -322,4 +304,3 @@
     Condition
       Error:
       ! No S7 class for base type <pairlist>.
-
diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R
index 5cc0f8ac..6248d70d 100644
--- a/tests/testthat/helper.R
+++ b/tests/testthat/helper.R
@@ -102,13 +102,13 @@ local_S4_class <- function(
   where = topenv(env)
 ) {
   out <- methods::setClass(name, ..., where = where)
-  defer(S4_remove_classes(name, env), env)
+  defer(S4_remove_classes(name, where), env)
   out
 }
 
 local_S4_union <- function(name, members, env = parent.frame()) {
   out <- methods::setClassUnion(name, members, where = topenv(env))
-  defer(S4_remove_classes(name, env), env)
+  defer(S4_remove_classes(name, topenv(env)), env)
   out
 }
 
diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R
index 8944b286..f7512701 100644
--- a/tests/testthat/test-S4.R
+++ b/tests/testthat/test-S4.R
@@ -6,13 +6,50 @@ test_that("can work with classGenerators", {
 test_that("S4_register registers an S7 class so it can be used with S4 methods", {
   defer(S4_remove_classes("S4regS7"))
   S4regS7 := new_class(package = NULL)
-  S4_register(S4regS7)
+  S4regS7_S4 <- S4_register(S4regS7)
+  expect_equal(S4regS7_S4, "S4regS7")
   expect_contains(methods::extends("S4regS7"), c("S4regS7", "S7_object"))
 })
 
+test_that("S4_contains requires prior S4 registration", {
+  on.exit(S4_remove_classes("S4regContainsUnregistered"))
+  S4regContainsUnregistered := new_class(package = NULL)
+
+  expect_error(
+    S4_contains(S4regContainsUnregistered),
+    "has not been registered"
+  )
+  expect_false(methods::isClass("S4regContainsUnregistered"))
+
+  S4_register(S4regContainsUnregistered)
+  expect_equal(
+    S4_contains(S4regContainsUnregistered),
+    "S4regContainsUnregistered"
+  )
+})
+
+test_that("S4_register registers S4 old classes as virtual S7_object descendants", {
+  on.exit(S4_remove_classes(c("S4regParent", "S4regS7New")))
+  setClass("S4regParent", slots = list(x = "numeric"))
+  S4regS7New <- new_class(
+    "S4regS7New",
+    parent = getClass("S4regParent"),
+    properties = list(x = class_numeric),
+    package = NULL
+  )
+
+  expect_error(
+    methods::new("S4regS7New"),
+    "trying to generate an object from a virtual class"
+  )
+  expect_true(methods::extends("S4regS7New", "S7_object"))
+  expect_true("_S7_class" %in% methods::slotNames("S4regS7New"))
+})
+
 test_that("S4_register registers an S3 class so it can be used with S4 methods", {
   defer(S4_remove_classes(c("S4regS3a", "S4regS3b")))
-  S4_register(new_S3_class(c("S4regS3a", "S4regS3b")))
+  S4regS3_S4 <- S4_register(new_S3_class(c("S4regS3a", "S4regS3b")))
+  expect_equal(S4regS3_S4, "S4regS3a")
   # Must not extend S7_object — that was a silent bug pre-fix
   expect_equal(
     methods::extends("S4regS3a"),
@@ -20,6 +57,522 @@ test_that("S4_register registers an S3 class so it can be used with S4 methods",
   )
 })
 
+test_that("S4_register registers an S7 union so it can be used with S4 methods", {
+  on.exit({
+    if (methods::isGeneric("S4regUnionGeneric")) {
+      methods::removeGeneric("S4regUnionGeneric")
+    }
+    S4_remove_classes(c(
+      "S4regUnionFoo",
+      "S4regUnionFoo_OR_character"
+    ))
+  })
+
+  S4regUnionFoo <- new_class("S4regUnionFoo", package = NULL)
+  S4_register(S4regUnionFoo)
+  S4regUnion <- S4regUnionFoo | class_character
+  S4regUnion_S4 <- S4_register(S4regUnion)
+  expect_equal(S4regUnion_S4, "S4regUnionFoo_OR_character")
+
+  methods::setGeneric(
+    "S4regUnionGeneric",
+    function(x) standardGeneric("S4regUnionGeneric")
+  )
+  method(S4regUnionGeneric, S4regUnion) <- function(x) "union"
+
+  expect_equal(S4regUnionGeneric(S4regUnionFoo()), "union")
+  expect_equal(S4regUnionGeneric("x"), "union")
+})
+
+test_that("S4_register can reify S7 properties as slots for S4 subclasses", {
+  on.exit({
+    if (methods::isGeneric("S4regContainsGeneric")) {
+      methods::removeGeneric("S4regContainsGeneric")
+    }
+    S4_remove_classes(c(
+      "S4regContainsS4Child",
+      "S7::S4regContains",
+      "S7::S4regContainsChild"
+    ))
+  })
+
+  S4regContains <- new_class(
+    "S4regContains",
+    properties = list(x = class_numeric),
+    package = "S7"
+  )
+  S4regContainsChild <- new_class(
+    "S4regContainsChild",
+    parent = S4regContains,
+    properties = list(y = class_character),
+    validator = function(self) {
+      if (identical(self@y, "bad")) "bad y"
+    },
+    package = "S7"
+  )
+
+  S4regContainsChild_old <- S4_register(S4regContainsChild)
+  S4regContainsChild_S4 <- S4_contains(S4regContainsChild)
+  expect_equal(S4regContainsChild_S4, "S7::S4regContainsChild")
+  expect_equal(
+    methods::slotNames(S4regContainsChild_S4),
+    c("y", "x", "_S7_class", ".S3Class")
+  )
+  expect_contains(
+    methods::extends(S4regContainsChild_S4),
+    S4regContainsChild_old
+  )
+
+  methods::setClass(
+    "S4regContainsS4Child",
+    contains = S4regContainsChild_S4,
+    slots = list(z = "logical")
+  )
+  object <- methods::new(
+    "S4regContainsS4Child",
+    x = 1,
+    y = "a",
+    z = TRUE
+  )
+
+  expect_equal(methods::slot(object, "x"), 1)
+  expect_equal(methods::slot(object, "y"), "a")
+  expect_equal(methods::slot(object, "z"), TRUE)
+  expect_equal(methods::slot(object, "_S7_class"), S4regContainsChild)
+  expect_equal(prop_names(object), c("x", "y"))
+  expect_equal(prop(object, "x"), 1)
+  expect_equal(prop(object, "y"), "a")
+  expect_true(methods::validObject(object))
+  expect_equal(S7_class(object), S4regContainsChild)
+  expect_match(obj_desc(object), "^S4<")
+
+  expect_equal(
+    S4_to_S7_class(getClass("S4regContainsS4Child")),
+    getClass("S4regContainsS4Child")
+  )
+  expect_contains(
+    obj_dispatch(object),
+    c(
+      S4_class_name(getClass("S4regContainsS4Child")),
+      S4regContainsChild_old
+    )
+  )
+
+  S4regContainsDispatch <- new_generic("S4regContainsDispatch", "x")
+  method(S4regContainsDispatch, S4regContainsChild) <- function(x) {
+    "S7"
+  }
+  method(
+    S4regContainsDispatch,
+    getClass("S4regContainsS4Child")
+  ) <- function(x) {
+    "S4"
+  }
+  expect_equal(S4regContainsDispatch(object), "S4")
+
+  invalid <- object
+  methods::slot(invalid, "y") <- "bad"
+  expect_error(methods::validObject(invalid), "bad y")
+
+  methods::setGeneric(
+    "S4regContainsGeneric",
+    function(x) standardGeneric("S4regContainsGeneric")
+  )
+  method(S4regContainsGeneric, S4regContainsChild) <- function(x) {
+    methods::slot(x, "x")
+  }
+  expect_equal(S4regContainsGeneric(object), 1)
+})
+
+test_that("S4_register constructs S4 subclasses of S7 classes that extend S4 classes", {
+  on.exit(S4_remove_classes(c(
+    "S4regNewParent",
+    "S4regNewMiddle",
+    "S4regNewChild",
+    "S4regNewGrandChild"
+  )))
+  setClass(
+    "S4regNewParent",
+    slots = list(assays = "list", rowData = "character")
+  )
+  methods::setValidity("S4regNewParent", function(object) {
+    if (!identical(methods::slot(object, "assays"), list())) {
+      "assays slot was stripped during parent coercion"
+    } else {
+      TRUE
+    }
+  })
+
+  S4regNewMiddle <- new_class(
+    "S4regNewMiddle",
+    parent = getClass("S4regNewParent"),
+    properties = list(metadata = class_character),
+    validator = function(self) {
+      if (identical(self@metadata, "bad")) "bad metadata"
+    },
+    package = NULL
+  )
+  S4regNewChild <- new_class(
+    "S4regNewChild",
+    parent = S4regNewMiddle,
+    properties = list(status = class_character),
+    validator = function(self) {
+      if (identical(self@status, "bad")) "bad status"
+    },
+    package = NULL
+  )
+  S4regNewChild_S4 <- S4_contains(S4regNewChild)
+  expect_equal(
+    methods::slotNames("S4regNewChild"),
+    c("status", "metadata", "_S7_class", "assays", "rowData", ".S3Class")
+  )
+  expect_contains(
+    methods::slotNames(S4regNewChild_S4),
+    c("assays", "rowData", "metadata", "status", "_S7_class")
+  )
+  setClass(
+    "S4regNewGrandChild",
+    contains = S4regNewChild_S4
+  )
+
+  object <- methods::new("S4regNewGrandChild")
+
+  expect_true(isS4(object))
+  expect_true(methods::is(object, "S7_object"))
+  expect_true(methods::is(object, "S4regNewParent"))
+  expect_true(methods::is(object, S4regNewChild_S4))
+  expect_true(S7_inherits(object, S4regNewChild))
+  expect_equal(methods::slot(object, "_S7_class"), S4regNewChild)
+  expect_equal(methods::slot(object, "assays"), list())
+  expect_equal(methods::slot(object, "rowData"), character())
+  expect_equal(methods::slot(object, "metadata"), character())
+  expect_equal(methods::slot(object, "status"), character())
+  object_reified <- methods::as(object, S4regNewChild_S4)
+  object_old <- methods::as(object_reified, "S4regNewChild")
+  expect_equal(methods::slot(object_old, "metadata"), character())
+  expect_equal(methods::slot(object_old, "status"), character())
+  object_old <- methods::as(object, "S4regNewChild")
+  expect_equal(methods::slot(object_old, "metadata"), character())
+  expect_equal(methods::slot(object_old, "status"), character())
+  expect_equal(
+    prop_names(object),
+    c("assays", "rowData", "metadata", "status")
+  )
+  expect_equal(prop(object, "assays"), list())
+  expect_equal(prop(object, "rowData"), character())
+  expect_equal(prop(object, "metadata"), character())
+  expect_equal(prop(object, "status"), character())
+  expect_true(methods::validObject(object))
+
+  object <- methods::new(
+    "S4regNewGrandChild",
+    metadata = "m",
+    status = "s"
+  )
+  expect_equal(methods::slot(object, "metadata"), "m")
+  expect_equal(methods::slot(object, "status"), "s")
+  expect_true(methods::validObject(object))
+
+  invalid <- object
+  methods::slot(invalid, "metadata") <- "bad"
+  expect_error(methods::validObject(invalid), "bad metadata")
+
+  invalid <- object
+  methods::slot(invalid, "status") <- "bad"
+  expect_error(methods::validObject(invalid), "bad status")
+})
+
+test_that("S4_validate_class validates only matching S7 classes for S4 upcasts", {
+  on.exit(S4_remove_classes(c(
+    "S4regShimRoot",
+    "S4regShimParent",
+    "S4regShimChild",
+    "S4regShimGrandChild",
+    "S7::S4regShimParent",
+    "S7::S4regShimChild"
+  )))
+
+  setClass("S4regShimRoot", slots = list(root = "numeric"))
+  S4regShimParent <- new_class(
+    "S4regShimParent",
+    parent = getClass("S4regShimRoot"),
+    properties = list(x = class_numeric),
+    package = "S7"
+  )
+  S4regShimChild <- new_class(
+    "S4regShimChild",
+    parent = S4regShimParent,
+    properties = list(y = class_character),
+    package = "S7"
+  )
+
+  S4regShimParent_S4 <- S4_contains(S4regShimParent)
+  S4regShimChild_S4 <- S4_contains(S4regShimChild)
+  setClass("S4regShimParent", contains = S4regShimParent_S4)
+  setClass(
+    "S4regShimChild",
+    contains = c(S4regShimChild_S4, "S4regShimParent")
+  )
+  setClass("S4regShimGrandChild", contains = "S4regShimChild")
+
+  object <- methods::new("S4regShimGrandChild", root = 1, x = 2, y = "a")
+  parent_object <- methods::as(object, S4regShimParent_S4)
+
+  expect_equal(methods::slot(parent_object, "y"), "a")
+  expect_equal(S7_class(parent_object), S4regShimChild)
+  expect_true(methods::validObject(object))
+})
+
+test_that("S4_register registers abstract S7 classes as virtual S4 classes", {
+  on.exit({
+    try(methods::removeMethod("dim", "S4regAbstractConcrete"), silent = TRUE)
+    S4_remove_classes(c(
+      "S4regAbstractParent",
+      "S4regAbstract",
+      "S4regAbstractConcrete",
+      "S4regAbstractShim"
+    ))
+  })
+
+  setClass("S4regAbstractParent", contains = "VIRTUAL")
+  methods::setValidity("S4regAbstractParent", function(object) {
+    if (!identical(dim(object), c(1L, 2L))) {
+      "dim() did not dispatch to the concrete S7 class"
+    } else {
+      TRUE
+    }
+  })
+
+  S4regAbstract <- new_class(
+    "S4regAbstract",
+    parent = getClass("S4regAbstractParent"),
+    abstract = TRUE,
+    package = NULL
+  )
+  S4regAbstractConcrete <- new_class(
+    "S4regAbstractConcrete",
+    parent = S4regAbstract,
+    properties = list(x = class_integer),
+    package = NULL
+  )
+  method(dim, S4regAbstractConcrete) <- function(x) c(x@x, 2L)
+  S4regAbstractConcrete_S4 <- S4_contains(S4regAbstractConcrete)
+  setClass("S4regAbstractShim", contains = S4regAbstractConcrete_S4)
+
+  object <- methods::new("S4regAbstractShim", x = 1L)
+  abstract_prototype <- methods::getClass("S4regAbstract")@prototype
+  concrete_prototype <- methods::getClass("S4regAbstractConcrete")@prototype
+
+  expect_true(methods::isVirtualClass("S4regAbstract"))
+  expect_true("_S7_class" %in% methods::slotNames("S4regAbstract"))
+  expect_equal(methods::slot(abstract_prototype, "_S7_class"), S4regAbstract)
+  expect_false(methods::extends("S4regAbstract", "oldClass"))
+  expect_false(methods::extends("S4regAbstract", "S7_object"))
+  expect_equal(
+    methods::slot(concrete_prototype, "_S7_class"),
+    S4regAbstractConcrete
+  )
+  expect_false("S4regAbstract" %in% attr(concrete_prototype, ".S3Class"))
+  expect_equal(dim(object), c(1L, 2L))
+  expect_true(methods::validObject(object))
+})
+
+test_that("S4_register uses S7 property defaults as S4 prototypes", {
+  on.exit(S4_remove_classes(c(
+    "S4regPrototype",
+    "S4regPrototypeChild",
+    "NULL_OR_character"
+  )))
+
+  S4_register(NULL | class_character)
+  S4regPrototype <- new_class(
+    "S4regPrototype",
+    properties = list(
+      x = new_property(class_numeric, default = quote(1)),
+      y = new_property(class_character, default = quote("a")),
+      z = new_property(NULL | class_character, default = NULL)
+    ),
+    package = NULL
+  )
+  S4_register(S4regPrototype)
+  S4regPrototype_S4 <- S4_contains(S4regPrototype)
+  methods::setClass("S4regPrototypeChild", contains = S4regPrototype_S4)
+
+  object <- methods::new("S4regPrototypeChild")
+
+  expect_equal(methods::slot(object, "x"), 1)
+  expect_equal(methods::slot(object, "y"), "a")
+  expect_equal(methods::slot(object, "z"), NULL)
+  expect_equal(prop(object, "x"), 1)
+  expect_equal(prop(object, "y"), "a")
+  expect_equal(prop(object, "z"), NULL)
+  expect_true(methods::validObject(object))
+})
+
+test_that("S4_register treats S4 NULL slot sentinels as NULL-valued S7 properties", {
+  on.exit(S4_remove_classes(c(
+    "S4regNullable",
+    "S4regNullableChild",
+    "NULL_OR_character"
+  )))
+
+  S4_register(NULL | class_character)
+  S4regNullable <- new_class(
+    "S4regNullable",
+    properties = list(
+      x = new_property(NULL | class_character, default = NULL)
+    ),
+    package = NULL
+  )
+  S4_register(S4regNullable)
+  S4regNullable_S4 <- S4_contains(S4regNullable)
+  methods::setClass("S4regNullableChild", contains = S4regNullable_S4)
+
+  object <- methods::new("S4regNullableChild")
+
+  expect_equal(methods::slot(object, "x"), NULL)
+  expect_equal(prop(object, "x"), NULL)
+  expect_true(methods::validObject(object))
+  expect_no_error(methods::new("S4regNullableChild", x = NULL))
+
+  object_with_value <- methods::new("S4regNullableChild", x = "a")
+  prop(object_with_value, "x") <- NULL
+  expect_equal(methods::slot(object_with_value, "x"), NULL)
+  expect_equal(prop(object_with_value, "x"), NULL)
+
+  plain <- S4regNullable(x = "a")
+  prop(plain, "x") <- NULL
+  expect_equal(prop(plain, "x"), NULL)
+  expect_identical(attr(plain, "x", exact = TRUE), as.name("\001NULL\001"))
+})
+
+test_that("S4_contains rejects properties with custom accessors", {
+  on.exit(S4_remove_classes(c(
+    "S4regContainsDynamicChild",
+    "S7::S4regContainsDynamic",
+    "S4regContainsSetterChild",
+    "S7::S4regContainsSetter"
+  )))
+
+  S4regContainsDynamic <- new_class(
+    "S4regContainsDynamic",
+    properties = list(
+      x = new_property(class_numeric, getter = function(self) 1)
+    ),
+    package = "S7"
+  )
+  expect_no_error(S4_register(S4regContainsDynamic))
+  expect_error(
+    S4_contains(S4regContainsDynamic),
+    "custom getter"
+  )
+  methods::setClass(
+    "S4regContainsDynamicChild",
+    contains = "S7::S4regContainsDynamic"
+  )
+  expect_error(
+    methods::new("S4regContainsDynamicChild"),
+    "custom getter"
+  )
+
+  S4regContainsSetter <- new_class(
+    "S4regContainsSetter",
+    properties = list(
+      x = new_property(
+        class_numeric,
+        setter = function(self, value) {
+          attr(self, "x") <- value
+          self
+        }
+      )
+    ),
+    package = "S7"
+  )
+  expect_no_error(S4_register(S4regContainsSetter))
+  expect_error(
+    S4_contains(S4regContainsSetter),
+    "custom setter"
+  )
+  methods::setClass(
+    "S4regContainsSetterChild",
+    contains = "S7::S4regContainsSetter"
+  )
+  expect_error(
+    methods::new("S4regContainsSetterChild"),
+    "custom setter"
+  )
+})
+
+test_that("S4_register uses registered S7 unions as S4 slots", {
+  on.exit(S4_remove_classes(c(
+    "S7::S4regContainsUnion",
+    "integer_OR_numeric_OR_character"
+  )))
+
+  S4regContainsUnion <- new_class(
+    "S4regContainsUnion",
+    properties = list(x = class_numeric | class_character),
+    package = "S7"
+  )
+  expect_error(
+    S4_register(S4regContainsUnion),
+    "not been registered"
+  )
+
+  S4_register(class_numeric | class_character)
+  S4_register(S4regContainsUnion)
+  S4regContainsUnion_S4 <- S4_contains(S4regContainsUnion)
+  expect_equal(
+    as.character(methods::getClass(S4regContainsUnion_S4)@slots$x),
+    "integer_OR_numeric_OR_character"
+  )
+})
+
+test_that("S4_register uses matching S4 unions as S4 slots", {
+  env <- topenv(environment())
+  on.exit(S4_remove_classes(
+    c(
+      "S4regContainsExistingUnion",
+      "S4regExistingUnion",
+      "S4regUnionMember2",
+      "S4regUnionMember1"
+    ),
+    env
+  ))
+
+  setClass("S4regUnionMember1", where = env)
+  setClass("S4regUnionMember2", where = env)
+  setClassUnion(
+    "S4regExistingUnion",
+    c("S4regUnionMember1", "S4regUnionMember2"),
+    where = env
+  )
+
+  S4regContainsExistingUnion <- new_class(
+    "S4regContainsExistingUnion",
+    properties = list(
+      x = getClass("S4regUnionMember1", where = env) |
+        getClass("S4regUnionMember2", where = env)
+    ),
+    package = NULL
+  )
+
+  S4_register(S4regContainsExistingUnion, env)
+  S4regContainsExistingUnion_S4 <- S4_contains(
+    S4regContainsExistingUnion,
+    env
+  )
+  expect_equal(
+    as.character(
+      methods::getClass(
+        S4regContainsExistingUnion_S4,
+        where = env
+      )@slots$x
+    ),
+    "S4regExistingUnion"
+  )
+})
+
 test_that("S4_register errors on unsupported inputs", {
   expect_snapshot(error = TRUE, {
     S4_register(1)
@@ -50,6 +603,37 @@ test_that("converts S4 unions to S7 unions", {
   )
 })
 
+test_that("S4 slot properties convert S4 class unions to S7 unions", {
+  env <- topenv(environment())
+  on.exit(S4_remove_classes(
+    c(
+      "S4regUnionSlotChild",
+      "S4regUnionSlotParent",
+      "S4regUnionSlot"
+    ),
+    env
+  ))
+
+  setClassUnion("S4regUnionSlot", c("character", "NULL"), where = env)
+  setClass(
+    "S4regUnionSlotParent",
+    slots = list(u = "S4regUnionSlot"),
+    where = env
+  )
+
+  S4regUnionSlotChild <- new_class(
+    "S4regUnionSlotChild",
+    parent = getClass("S4regUnionSlotParent", where = env),
+    properties = list(y = class_character),
+    package = NULL
+  )
+
+  expect_equal(
+    S4regUnionSlotChild@properties$u$class,
+    new_union(NULL, class_character)
+  )
+})
+
 test_that("converts S4 representation of S3 classes to S7 representation", {
   expect_equal(
     S4_to_S7_class(getClass("Date")),
@@ -62,6 +646,175 @@ test_that("errors on non-S4 classes", {
   expect_snapshot(S4_to_S7_class(1), error = TRUE)
 })
 
+test_that("S7 classes can extend S4 classes", {
+  on.exit(S4_remove_classes(c("Parent", "Child")))
+  setClass("Parent", slots = list(x = "numeric"))
+
+  Child <- new_class(
+    "Child",
+    parent = getClass("Parent"),
+    properties = list(y = class_character),
+    package = NULL
+  )
+  child <- Child(x = 1, y = "a")
+
+  expect_false(isS4(child))
+  expect_true(S7_inherits(child, Child))
+  expect_equal(prop_names(child), c("x", "y"))
+  expect_equal(prop(child, "x"), 1)
+  expect_equal(prop(child, "y"), "a")
+
+  prop(child, "x") <- 2
+  prop(child, "y") <- "b"
+  expect_equal(prop(child, "x"), 2)
+  expect_equal(prop(child, "y"), "b")
+
+  expect_true(methods::is(child, "Parent"))
+  expect_true(methods::validObject(child))
+  expect_equal(as.character(methods::getClass("Child")@className), "Child")
+  expect_equal(
+    methods::slotNames("Child"),
+    c("y", "_S7_class", "x", ".S3Class")
+  )
+  expect_equal(methods::slot(child, "x"), 2)
+  expect_equal(methods::slot(child, "y"), "b")
+
+  child <- methods::initialize(child, x = 3, y = "c")
+  expect_equal(prop(child, "x"), 3)
+  expect_equal(prop(child, "y"), "c")
+  expect_true(methods::validObject(child))
+
+  child <- methods::initialize(child, Child(x = 4, y = "d"), y = "e")
+  expect_equal(prop(child, "x"), 4)
+  expect_equal(prop(child, "y"), "e")
+
+  parent <- methods::new("Parent", x = 5)
+  child <- methods::initialize(child, parent, y = "f")
+  expect_equal(prop(child, "x"), 5)
+  expect_equal(prop(child, "y"), "f")
+
+  child <- methods::initialize(child, x = 6, x = 7)
+  expect_equal(prop(child, "x"), 7)
+
+  expect_error(methods::initialize(child, x = "x"), "invalid")
+  expect_error(methods::initialize(child, z = 1), "Property not found")
+
+  expect_error(Child(x = "x", y = "a"))
+})
+
+test_that("S4 initialization sets S4 slots on subclasses of S7 classes", {
+  on.exit(S4_remove_classes(c(
+    "ParentForSlots",
+    "ChildForSlots",
+    "S4ChildForSlots"
+  )))
+  setClass("ParentForSlots", slots = list(x = "numeric"))
+
+  ChildForSlots <- new_class(
+    "ChildForSlots",
+    parent = getClass("ParentForSlots"),
+    properties = list(y = class_character),
+    package = NULL
+  )
+
+  setClass(
+    "S4ChildForSlots",
+    slots = list(z = "character"),
+    contains = "ChildForSlots"
+  )
+
+  parent <- ChildForSlots(x = 1, y = "a")
+  child <- methods::new("S4ChildForSlots", parent, z = "b")
+
+  expect_true(isS4(child))
+  expect_true(S7_inherits(child, ChildForSlots))
+  expect_equal(prop(child, "x"), 1)
+  expect_equal(prop(child, "y"), "a")
+  expect_equal(methods::slot(child, "z"), "b")
+
+  child@z <- "c"
+  child@y <- "d"
+  expect_equal(methods::slot(child, "z"), "c")
+  expect_equal(prop(child, "y"), "d")
+})
+
+test_that("@<- sets S4-only slots on subclasses of S7 classes", {
+  on.exit(S4_remove_classes(c("ParentForAt", "ChildForAt", "S4ChildForAt")))
+  setClass("ParentForAt", slots = list(x = "numeric"))
+
+  ChildForAt <- new_class(
+    "ChildForAt",
+    parent = getClass("ParentForAt"),
+    properties = list(y = class_character),
+    package = NULL
+  )
+
+  setClass(
+    "S4ChildForAt",
+    slots = list(z = "character"),
+    contains = "ChildForAt"
+  )
+
+  child <- methods::new("S4ChildForAt", ChildForAt(x = 1, y = "a"), z = "b")
+  child@z <- "c"
+  child@y <- "d"
+
+  expect_equal(methods::slot(child, "z"), "c")
+  expect_equal(prop(child, "y"), "d")
+})
+
+test_that("S4 initialize supports S3 data parts", {
+  on.exit(S4_remove_classes(c("ParentNum", "ChildNum")))
+  setClass("ParentNum", contains = "numeric", slots = list(y = "character"))
+
+  ChildNum <- new_class(
+    "ChildNum",
+    parent = getClass("ParentNum"),
+    properties = list(z = class_integer),
+    package = NULL
+  )
+  child <- ChildNum(y = "a", z = 1L)
+
+  child <- methods::initialize(child, 2.5, y = "b")
+  expect_equal(as.vector(child), 2.5)
+  expect_equal(prop(child, ".Data"), 2.5)
+  expect_equal(prop(child, "y"), "b")
+  expect_true(methods::validObject(child))
+
+  child <- methods::initialize(child, .Data = 3.5)
+  expect_equal(as.vector(child), 3.5)
+  expect_true(methods::validObject(child))
+})
+
+test_that("S4 classes can not extend S7-over-S4 classes with property setters", {
+  on.exit(S4_remove_classes(c("Parent2", "Child2", "S4Child2")))
+  setClass("Parent2", slots = list(x = "numeric"))
+
+  Child2 <- new_class(
+    "Child2",
+    parent = getClass("Parent2"),
+    properties = list(
+      y = new_property(class_character, setter = function(self, value) {
+        attr(self, "setter_called") <- TRUE
+        attr(self, "y") <- value
+        self
+      })
+    ),
+    package = NULL
+  )
+  expect_true(attr(Child2(x = 1, y = "a"), "setter_called", exact = TRUE))
+  expect_error(
+    S4_contains(Child2),
+    "custom setter"
+  )
+
+  methods::setClass("S4Child2", contains = "Child2")
+  expect_error(
+    methods::new("S4Child2"),
+    "custom setter"
+  )
+})
+
 
 test_that("S4_class_dispatch returns name of base class", {
   Foo1 := local_S4_class(slots = list("x" = "numeric"))
@@ -121,6 +874,20 @@ test_that("S4_class_dispatch ignores unions", {
   expect_equal(S4_class_dispatch("Foo2"), "S4/S7::Foo2")
 })
 
+test_that("S4_class_dispatch dispatches through the full S3 old-class hierarchy", {
+  setOldClass(c("S4OldS3a", "S4OldS3b"))
+  defer(S4_remove_classes(c("S4OldS3Child", "S4OldS3a", "S4OldS3b")))
+  setClass("S4OldS3Child", contains = "S4OldS3a")
+
+  generic <- new_generic("S4OldS3Generic", "x")
+  method(generic, new_S3_class("S4OldS3b")) <- function(x) "S3 parent"
+
+  object <- methods::new("S4OldS3Child")
+
+  expect_contains(obj_dispatch(object), "S4OldS3b")
+  expect_equal(generic(object), "S3 parent")
+})
+
 test_that("S4_class_dispatch includes virtual classes", {
   Foo1 := local_S4_class()
   Foo2 := local_S4_class(contains = "Foo1")
@@ -141,6 +908,45 @@ test_that("S4_class_dispatch captures implicit package name", {
   expect_equal(S4_class_dispatch("Foo1"), "S4/mypkg::Foo1")
 })
 
+test_that("S7 class extending S4 class with multiple parents works", {
+  on.exit(S4_remove_classes(c(
+    "MultiParent1",
+    "MultiParent2",
+    "MultiChild",
+    "S7MultiChild",
+    "S7MultiChild2"
+  )))
+
+  setClass("MultiParent1", slots = list(x = "numeric"))
+  setClass("MultiParent2", slots = list(y = "numeric"))
+  setClass("MultiChild", contains = c("MultiParent1", "MultiParent2"))
+
+  S7MultiChild <- new_class(
+    "S7MultiChild",
+    parent = getClass("MultiChild"),
+    properties = list(z = class_numeric),
+    package = NULL
+  )
+
+  S7MultiChild2 <- new_class(
+    "S7MultiChild2",
+    parent = S7MultiChild,
+    properties = list(w = class_numeric),
+    package = NULL
+  )
+
+  obj <- S7MultiChild2(x = 1, y = 2, z = 3, w = 4)
+  expect_true(S7_inherits(obj, S7MultiChild2))
+  expect_true(S7_inherits(obj, S7MultiChild))
+  expect_equal(prop(obj, "x"), 1)
+  expect_equal(prop(obj, "y"), 2)
+  expect_equal(prop(obj, "z"), 3)
+  expect_equal(prop(obj, "w"), 4)
+
+  expect_true(methods::is(obj, "MultiParent1"))
+  expect_true(methods::is(obj, "MultiParent2"))
+})
+
 test_that("S4_package_name resolves S4 package name correctly in all cases", {
   stats_ns <- asNamespace("stats")
 
diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R
index cb3ddc66..c5dd7975 100644
--- a/tests/testthat/test-class.R
+++ b/tests/testthat/test-class.R
@@ -60,12 +60,17 @@ test_that("S7 classes check inputs", {
   })
 })
 
-test_that("S7 classes can't inherit from S4 or class unions", {
+test_that("S7 classes can inherit from S4 but not class unions", {
   parentS4 := local_S4_class(slots = c(x = "numeric"))
-  expect_snapshot(error = TRUE, {
-    new_class("test", parent = parentS4)
-    new_class("test", parent = new_union("character"))
-  })
+
+  child <- new_class("test", parent = parentS4, package = NULL)
+  expect_s3_class(child, "S7_class")
+  expect_s4_class(child@parent, "classRepresentation")
+  expect_equal(as.character(child@parent@className), "parentS4")
+  expect_error(
+    new_class("test", parent = new_union(class_character)),
+    "`parent` must be an S7 class, S4 class, S3 class, or base type"
+  )
 })
 
 test_that("inheritance combines properties for parent classes", {
diff --git a/tests/testthat/test-convert.R b/tests/testthat/test-convert.R
index f6b476b3..37298acd 100644
--- a/tests/testthat/test-convert.R
+++ b/tests/testthat/test-convert.R
@@ -136,6 +136,49 @@ test_that("fallback convert can convert to base type", {
   expect_equal(attr(obj, "x"), NULL)
 })
 
+test_that("fallback convert can convert_up() an S4-derived S7 object to an S4 object", {
+  on.exit(S4_remove_classes(c("ParentS4", "ChildS7")))
+  setClass("ParentS4", slots = list(x = "numeric"))
+
+  ChildS7 <- new_class(
+    "ChildS7",
+    parent = getClass("ParentS4"),
+    properties = list(y = class_character),
+    package = NULL
+  )
+
+  child <- ChildS7(x = 10, y = "a")
+  parent <- convert(child, to = getClass("ParentS4"))
+
+  expect_true(isS4(parent))
+  expect_equal(class(parent)[1L], "ParentS4")
+  expect_equal(methods::slot(parent, "x"), 10)
+})
+
+test_that("fallback convert can use explicit S4 coercion via methods::as", {
+  on.exit(S4_remove_classes(c("ParentS4", "ChildS7", "UnrelatedS4")))
+  setClass("ParentS4", slots = list(x = "numeric"))
+  setClass("UnrelatedS4", slots = list(z = "character"))
+
+  ChildS7 <- new_class(
+    "ChildS7",
+    parent = getClass("ParentS4"),
+    properties = list(y = class_character),
+    package = NULL
+  )
+
+  setAs("ChildS7", "UnrelatedS4", function(from) {
+    new("UnrelatedS4", z = as.character(methods::slot(from, "x")))
+  })
+
+  child <- ChildS7(x = 42, y = "a")
+  res <- convert(child, to = getClass("UnrelatedS4"))
+
+  expect_true(isS4(res))
+  expect_equal(class(res)[1L], "UnrelatedS4")
+  expect_equal(methods::slot(res, "z"), "42")
+})
+
 test_that("is_down_cast() is TRUE only when `to` descends from `from` (#509)", {
   Base := new_class(package = NULL)
   A := new_class(
diff --git a/tests/testthat/test-method-register-S3.R b/tests/testthat/test-method-register-S3.R
index 9357398f..77ba65a5 100644
--- a/tests/testthat/test-method-register-S3.R
+++ b/tests/testthat/test-method-register-S3.R
@@ -55,6 +55,116 @@ test_that("can register S7 method for S3 generic with S3 class signature", {
   expect_equal(s3_gen(factor("a")), "factor")
 })
 
+test_that("internal generics register S4 methods for S4-backed S7 classes", {
+  on.exit({
+    try(methods::removeMethod("dim", "S4regDimParent"), silent = TRUE)
+    try(methods::removeMethod("dim", "S4regDimChild"), silent = TRUE)
+    S4_remove_classes(c(
+      "S4regDimParent",
+      "S4regDimChild",
+      "S4regDimShim"
+    ))
+  })
+
+  setClass("S4regDimParent", contains = "VIRTUAL")
+  setMethod("dim", "S4regDimParent", function(x) {
+    stop("parent S4 method should not be called", call. = FALSE)
+  })
+  S4regDimChild <- new_class(
+    "S4regDimChild",
+    parent = getClass("S4regDimParent"),
+    properties = list(x = class_integer),
+    package = NULL
+  )
+  method(dim, S4regDimChild) <- function(x) c(x@x, 2L)
+  S4regDimChild_S4 <- S4_contains(S4regDimChild)
+  setClass("S4regDimShim", contains = S4regDimChild_S4)
+
+  object <- methods::new("S4regDimShim", x = 1L)
+
+  expect_true(isS4(object))
+  expect_equal(dim(object), c(1L, 2L))
+})
+
+test_that("internal replacement generics can register full S4 signatures", {
+  on.exit({
+    try(
+      methods::removeMethod(
+        "dimnames<-",
+        c("S4regDimnamesChild", "list")
+      ),
+      silent = TRUE
+    )
+    S4_remove_classes(c(
+      "S4regDimnamesParent",
+      "S4regDimnamesChild",
+      "S4regDimnamesShim"
+    ))
+  })
+
+  setClass("S4regDimnamesParent", contains = "VIRTUAL")
+  S4regDimnamesChild <- new_class(
+    "S4regDimnamesChild",
+    parent = getClass("S4regDimnamesParent"),
+    properties = list(x = class_list),
+    package = NULL
+  )
+  method(`dimnames<-`, list(S4regDimnamesChild, class_list)) <-
+    function(x, value) {
+      x@x <- value
+      x
+    }
+  S4regDimnamesChild_S4 <- S4_contains(S4regDimnamesChild)
+  setClass("S4regDimnamesShim", contains = S4regDimnamesChild_S4)
+
+  object <- methods::new("S4regDimnamesShim", x = list(NULL, NULL))
+  value <- list("r", "c")
+  dimnames(object) <- value
+
+  expect_equal(methods::slot(object, "x"), value)
+  expect_true(methods::hasMethod(
+    "dimnames<-",
+    c("S4regDimnamesChild", "list")
+  ))
+})
+
+test_that("sentinels for internal replacement generics keep full S4 signatures", {
+  on.exit(S4_remove_classes(c(
+    "S4regDimnamesSentinelParent",
+    "S4regDimnamesSentinelChild"
+  )))
+
+  setClass("S4regDimnamesSentinelParent", contains = "VIRTUAL")
+  S4regDimnamesSentinelChild <- new_class(
+    "S4regDimnamesSentinelChild",
+    parent = getClass("S4regDimnamesSentinelParent"),
+    properties = list(x = class_list),
+    package = NULL
+  )
+
+  dimnames_sentinel <- generic_sentinel(as_generic(`dimnames<-`))
+  expect_no_error(
+    register_method(
+      dimnames_sentinel,
+      list(S4regDimnamesSentinelChild, class_list),
+      function(x, value) x,
+      package = NULL
+    )
+  )
+  on.exit(
+    methods::removeMethod(
+      "dimnames<-",
+      c("S4regDimnamesSentinelChild", "list")
+    ),
+    add = TRUE,
+    after = FALSE
+  )
+  expect_true(methods::hasMethod(
+    "dimnames<-",
+    c("S4regDimnamesSentinelChild", "list")
+  ))
+})
+
 test_that("S3 registration for a multi-class S3 class uses only the first class", {
   local_s3_generic("s3_gen")
   method(s3_gen, new_S3_class(c("ordered", "factor"))) <- function(x) "ord"
diff --git a/vignettes/compatibility.Rmd b/vignettes/compatibility.Rmd
index bd9ef80e..b79a4e88 100644
--- a/vignettes/compatibility.Rmd
+++ b/vignettes/compatibility.Rmd
@@ -26,7 +26,7 @@ library(S7)
 S7 objects *are* S3 objects, because S7 is implemented on top of S3.
 There are two main differences between an S7 object and an S3 object:
 
--   As well as the `class` attribute possessed by S3 objects, S7 objects have an additional `S7_class` attribute that contains the object that defines the class.
+-   As well as the `class` attribute possessed by S3 objects, S7 objects have an additional `_S7_class` attribute that contains the object that defines the class.
 
 -   S7 objects have properties; S3 objects have attributes.
     Properties are implemented on top of attributes, so you can access them directly with `attr` and friends.
@@ -143,16 +143,142 @@ The chief disadvantage of this approach is any subclasses will need to be conver
 
 ## S4
 
-S7 properties are equivalent to S4 slots.
-The chief difference is that they can be dynamic.
+S7 properties play a role similar to S4 slots.
+The chief difference is that S7 properties can be dynamic, while S4 slots are
+stored fields with a declared S4 class.
 
--   S7 classes can not extend S4 classes
--   S4 classes can extend S3 classes
--   S7 can register methods for S4 generics and S4 classes
+S7 and S4 can interoperate in both directions:
+
+-   S7 classes can extend S4 classes.
+-   S4 classes can extend S7 classes.
+-   S7 can register methods for S4 generics and S4 classes.
+
+### S7 classes that extend S4 classes
+
+To extend an S4 class, supply its class definition or class generator as the
+`parent` of a new S7 class. The S4 parent slots become S7 properties on the new
+class, and `new_class()` automatically registers the S7 class with S4.
+
+```{r}
+methods::setClass("S4Point",
+  slots = c(x = "numeric", y = "numeric")
+)
+
+ColoredPoint <- new_class("ColoredPoint",
+  parent = methods::getClass("S4Point"),
+  properties = list(color = class_character)
+)
+
+pt <- ColoredPoint(x = 1, y = 2, color = "red")
+pt@x
+pt@color
+methods::is(pt, "S4Point")
+```
+
+S4 dispatch follows the S4 parent hierarchy, so S4 methods defined for the
+parent can be called on the S7 child.
+
+```{r}
+methods::setGeneric("radius", function(x) standardGeneric("radius"))
+methods::setMethod("radius", "S4Point", function(x) {
+  sqrt(x@x^2 + x@y^2)
+})
+
+radius(pt)
+```
+
+S4 code that updates an existing object should use `initialize()` rather than
+constructing a new object from `class(x)`. The S7 `initialize()` method accepts
+stored S7 properties and S4 slots, and later arguments override earlier ones.
+
+```{r}
+pt <- methods::initialize(pt, x = 3, color = "blue")
+pt@x
+pt@color
+```
+
+There are a few important caveats:
+
+-   An S7 object that directly extends S4 is represented as an S3 old-class
+    object, so `isS4(pt)` is `FALSE`. Use `methods::is()` to ask about S4
+    inheritance.
+-   The class vector is not scalar. S4 code that needs one primary class name
+    should use `class(x)[1L]`, or `methods::class1(x)` when available.
+-   `methods::slot()` and `methods::slot<-()` can read and write stored
+    properties, but they bypass custom S7 getters, setters, and ordinary S7
+    validation. Call `methods::validObject()` after direct slot updates when
+    the object should satisfy the S7 contract.
+-   Properties with custom getters or setters cannot cross the S4 inheritance
+    boundary as S4 slots.
+-   `NULL` properties are stored using the same sentinel that S4 uses for
+    `NULL` slots. `prop()`, `@`, and `methods::slot()` translate this back to
+    `NULL`; raw attributes should be treated as an implementation detail.
+
+### S4 classes that extend S7 classes
+
+After calling `S4_register()`, use `S4_contains()` when an S4 class should
+extend an S7 class. It returns the virtual S4 class name for
+`methods::setClass(contains = )`. This class exposes stored S7 properties as
+formal S4 slots and carries the `_S7_class` slot that S7 uses for dispatch and
+validation.
+
+```{r}
+Sample <- new_class("Sample",
+  properties = list(
+    name = class_character,
+    score = class_numeric
+  ),
+  validator = function(self) {
+    if (length(self@score) != 1) {
+      "@score must have length 1"
+    } else if (self@score < 0) {
+      "@score must be non-negative"
+    }
+  }
+)
+
+S4_register(Sample)
+Sample_S4 <- S4_contains(Sample)
+methods::setClass("ReplicatedSample",
+  contains = Sample_S4,
+  slots = c(replicate = "integer")
+)
+
+rs <- methods::new("ReplicatedSample",
+  name = "A",
+  score = 3,
+  replicate = 1L
+)
+
+isS4(rs)
+rs@name
+prop(rs, "score")
+methods::validObject(rs)
+```
+
+S7 dispatch still sees the S7 class, even though the concrete object is an S4
+object.
+
+```{r}
+sample_label <- new_generic("sample_label", "x")
+method(sample_label, Sample) <- function(x) {
+  paste0(x@name, ": ", x@score)
+}
+
+sample_label(rs)
+```
+
+The class returned by `S4_contains()` is a compatibility layer,
+not a user-facing class. Do not instantiate it directly; use it only as a
+superclass for another S4 class. Since S4 subclasses are real S4 objects, S4
+code can access the S7 properties as slots. This is necessary for
+compatibility, but it also means S4 code can bypass S7 property setters until
+validation is run.
 
 ### Unions
 
-S4 unions are automatically converted to S7 unions.
+S4 unions are automatically converted to S7 unions when they are used as S7
+property classes.
 There's an important difference in the way that class unions are handled in S4 and S7.
 In S4, they're handled at method dispatch time, so when you create `setUnion("u1", c("class1", "class2"))`, `class1` and `class2` now extend `u1`.
 In S7, unions are handled at method registration time so that registering a method for a union is just short-hand for registering a method for each of the classes.
@@ -168,3 +294,5 @@ foo
 ```
 
 S7 unions allow you to restrict the type of a property in the same way that S4 unions allow you to restrict the type of a slot.
+S7 unions can also be registered with `S4_register()` for use in S4 slots and
+method signatures.